--- /dev/null
+ OPT PRT
+
+* fig-FORTH FOR 6809
+* ASSEMBLY SOURCE LISTING
+
+* RELEASE 0
+* JAN 2019
+* WITH COMPILER SECURITY
+* AND VARIABLE LENGTH NAMES
+*
+* Adapted by Joel Matthew Rees
+* from fig-FORTH for 6800 by Dave Lion, et. al.
+
+* This free/libre/open source publication is provided
+* through the courtesy of:
+* FORTH
+* INTEREST
+* GROUP
+* fig
+* and other interested parties.
+
+* Ancient address:
+* P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
+* URL: http://www.forth.org
+* Further distribution must include this notice.
+ PAGE
+ NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
+ OPT NOG,PAG
+* filename fig-forth-auto6809opt.asm
+* === FORTH-6809 {date} {time}
+
+
+* Permission is hereby granted, free of charge, to any person obtaining a copy
+* of this software and associated documentation files (the "Software"), to deal
+* in the Software without restriction, including without limitation the rights
+* to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+* copies of the Software, and to permit persons to whom the Software is
+* furnished to do so, subject to the following conditions:
+*
+* The above copyright notice and this permission notice shall be included in
+* all copies or substantial portions of the Software.
+
+* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+* THE SOFTWARE.
+*
+* "Associated documentation" for this declaration of license
+* shall be interpreted to include only the comments in this file,
+* or, if the code is split into multiple files,
+* all files containing the complete source.
+*
+* This is the MIT model license, as published by the Open Source Consortium,
+* with associated documentation defined.
+* It was chosen to reflect the spirit of the original
+* terms of use, which used archaic legal terminology.
+*
+
+* Authors of the 6800 model:
+* === Primary: Dave Lion,
+* === with help from
+* === Bob Smith,
+* === LaFarr Stuart,
+* === The Forth Interest Group
+* === PO Box 1105
+* === San Carlos, CA 94070
+* === and
+* === Unbounded Computing
+* === 1134-K Aster Ave.
+* === Sunnyvale, CA 94086
+*
+NATWID EQU 2 ; bytes per natural integer/pointer
+* The original version was developed on an AMI EVK 300 PROTO
+* system using an ACIA for the I/O.
+* This version is developed targeting the Tandy Color Computer.
+
+* All terminal 1/0
+* is done in three subroutines:
+* PEMIT ( word # 182 )
+* PKEY ( 183 )
+* PQTERM ( 184 )
+*
+* The FORTH words for disc related I/O follow the model
+* of the FORTH Interest Group, but have not yet been
+* tested using a real disc.
+*
+* Addresses in the 6800 implementation reflect the fact that,
+* on the development system, it was convenient to
+* write-protect memory at hex 1000, and leave the first
+* 4K bytes write-enabled. As a consequence, code from
+* location $1000 to lable ZZZZ could be put in ROM.
+* Minor deviations from the model were made in the
+* initialization and words ?STACK and FORGET
+* in order to do this.
+* Those deviations will be altered in this
+* implementation for the 6809 -- Color Computer.
+*
+
+* MEMORY MAP for this 16K|32K system:
+* ( delineated so that systems with 4k byte write-
+* protected segments can write protect FORTH )
+*
+* addr. contents pointer init by
+* **** ******************************* ******* ******
+*
+* Coco has no ACIA!
+* ACIAC EQU $FBCE the ACIA control address and
+* ACIAD EQU ACIAC+1 data address for PROTO
+*
+MEMT32 EQU $7FFF ; Theoretical absolute end of all ram
+MEMT16 EQU $3FFF ; 16K is too tight until we no longer need disc emulation.
+MEMTOP EQU MEMT32
+*
+MASSHI EQU MEMTOP
+*
+* 3FFF|7FFF HI
+*
+* substitute for disc mass memory
+RAMSCR EQU 8 ; addresses calculate as 2 (Too much for 16K in RAM only.)
+SCRSZ EQU 1024
+* 3800|7800 LO
+MASSLO EQU MASSHI-RAMSCR*SCRSZ+1
+RAMDSK EQU MASSLO
+MEMEND EQU MASSLO
+*
+* 3800|7800 MEMEND
+* "end" of "usable ram" (If disc mass memory emulation is removed, actual end.)
+*
+* 37FF|77FF
+*
+* per-user tables
+USERSZ EQU 256 ; (Addressable by DP, must be 256 on even boundary)
+USER16 EQU 1 ; We can change these for ROMPACK or 64K.
+USER32 EQU 2 ; maybe?
+USERCT EQU USER32
+USERLO EQU MEMEND-USERSZ*USERCT
+IUP EQU USERLO
+IUPDP EQU IUP/256
+* user tables of variables
+* registers & pointers for the virtual machine
+* scratch area for potential use in something, maybe?
+*
+* 3700|7600 <== UP
+*
+* This is a really awkward place to define the disk buffer records.
+*
+* 4 buffer sectors of VIRTUAL MEMORY
+NBLK EQU 4 ; # of disc buffer blocks for virtual memory
+* Should NBLK be SCRSZ/SECTSZ?
+* each block is SECTSZ+SECTRL bytes in size,
+* holding SECTSZ characters
+SECTSZ EQU 256
+SECTRL EQU 2*NATWID ; Currently held sector number, etc.
+BUFSZ EQU (SECTSZ+SECTRL)*NBLK
+BUFBAS EQU USERLO-BUFSZ
+* *BUG* SECTRL is hard-wired into several definitions.
+* It will take a bit of work to ferret them out.
+* It is too small, and it should not be hard-wired.
+* SECTSZ was also hard-wired into several definitions,
+* will I find them all?
+*
+* 32E0|71E0 FIRST
+*
+ PAGE
+*
+* Don't want one return too many to destroy the disc buffers.
+RPBUMP EQU 4*NATWID
+*
+* 32D8|71D8 <== RP RINIT
+*
+IRP EQU BUFBAS-RPBUMP
+* RETURN STACK
+RSTK16 EQU $50*NATWID ; 80 max levels nesting calls
+RSTK32 EQU $90*NATWID ; 144 max
+RSTKSZ EQU RSTK32
+*
+* 3248|70B8
+*
+SFTBND EQU IRP-RSTKSZ ; (false boundary between TIB and return stack)
+* INPUT LINE BUFFER
+* holds up to TIBSZ characters
+* and is scanned upward by IN
+* starting at TIB
+TIBSZ EQU 256
+ITIB EQU SFTBND-TIBSZ
+*
+* 3148|6FB8 <== IN TIB
+*
+* Don't want terminal input and parameter underflow collisions
+SPBUMP EQU 4*NATWID
+*
+ISP EQU ITIB-SPBUMP
+*
+* 3140|6FB0 <== SP SP0,SINIT
+* DATA STACK
+* | grows downward from 3140|6FB0
+* v
+* - -
+* ^
+* |
+* I DICTIONARY grows upward
+*
+* >>>>>>--------Two words to start RAMmable dictionary--------<<<<<<
+*
+* (2B00)
+* ???? end of ram-dictionary. <== DICTPT DPINIT
+* "TASK"
+*
+* ???? "FORTH" ( a word ) <=, <== CONTEXT
+* `==== CURRENT
+* start of ram-dictionary.
+*
+* >>>>>> memory from here up must be in RAM area <<<<<<
+*
+* ????
+* 6k of romable "FORTH" <== IP ABORT
+* <== W
+* the VIRTUAL FORTH MACHINE
+*
+* 1208 initialization tables
+* 1204 <<< WARM START ENTRY >>>
+* 1200 <<< COLD START ENTRY >>>
+* 1200 lowest address used by FORTH
+*
+CODEBG EQU $1200
+* CODEBG EQU $3000
+*
+* >>>>>> memory from here down left alone <<<<<<
+* >>>>>> so we can safely call ROM routines <<<<<<
+*
+* 0000
+ PAGE
+***
+*
+* CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
+*
+* IP (hardware Y) points to the current instruction ( pre-increment mode )
+* RP (hardware S) points to last return address pushedin return stack
+* SP (hardware U) points to last byte pushed in data stack
+*
+* Y must be IP when NEXT is entered (if using the inner loop).
+*
+* When A and B hold one 16 bit FORTH data word,
+* A contains the high byte, B, the low byte.
+*
+* UP (hardware DP) is the base of per-task ("user") variables.
+* (Be careful of the stray semantics of "user".)
+*
+* W (hardware X) is the pointer to the "code field" address of native CPU
+* machine code to be executed for the definition of the dictionary word
+* to be executed/currently executing.
+* The following natural integer (word) begins any "parameter section"
+* (body) -- similar to a "this" pointer, but not the same.
+* It may be native CPU machine code, or it may be a global variable,
+* or it may be a list of Forth definition words (addresses).
+*
+* ======
+* This implementation uses the native subroutine architecture
+* rather than a postponed-push call that the 6800 model VM uses
+* to save code and time in leaf routines.
+*
+* This should allow directly calling many of the Forth words
+* from assembly language code.
+* (Be aware of the need for a valid W in some cases.)
+* It won't allow mixing assembly language directly into Forth word lists.
+* ======
+*
+* boolean flags:
+* 0 is false, anything else is true.
+* Most places in this model that set a boolean flag set true as 1.
+* This is in contrast to many models that set a boolean flag as -1.
+*
+***
+
+ PAGE
+* This system is shown with one user (task),
+* but additional users (tasks) may be added
+* by allocating additional user tables:
+*
+ ORG IUP
+UBASE RMB USERSZ
+UBASEX RMB USERSZ data table for extra users
+*
+* Some of this stuff gets initialized during
+* COLD start and WARM start:
+* [ names correspond to FORTH words of similar (no X) name ]
+*
+ ORG IUP
+UORIG EQU *
+* A few useful VM variables
+* Will be removed when they are no longer needed.
+* All are replaced by 6809 registers.
+
+N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
+* SP@,SWAP,DOES>,COLD
+
+
+* These locations are used by the TRACE routine :
+
+TRLIM RMB 1 the count for tracing without user intervention
+TRACEM RMB 1 non-zero = trace mode
+BRKPT RMB 2 the breakpoint address at which
+* the program will go into trace mode
+VECT RMB 2 vector to machine code
+* (only needed if the TRACE routine is resident)
+
+
+* Registers used by the FORTH virtual machine:
+* Starting at $OOFO:
+
+
+W RMB 2 the instruction register points to 6800 code
+* This is not exactly accurate. Points to the definiton body,
+* which is native CPU machine code when it is native CPU machine code.
+* IP RMB 2 the instruction pointer points to pointer to 6800 code
+* RP RMB 2 the return stack pointer
+* UP RMB 2 the pointer to base of current user's 'USER' table
+* ( altered during multi-tasking )
+*
+*UORIG RMB 6 3 reserved variables
+ RMB 6 3 reserved variables
+XSPZER RMB 2 initial top of data stack for this user
+XRZERO RMB 2 initial top of return stack
+XTIB RMB 2 start of terminal input buffer
+XWIDTH RMB 2 name field width
+XWARN RMB 2 warning message mode (0 = no disc)
+XFENCE RMB 2 fence for FORGET
+XDICTP RMB 2 dictionary pointer
+XVOCL RMB 2 vocabulary linking
+XBLK RMB 2 disc block being accessed
+XIN RMB 2 scan pointer into the block
+XOUT RMB 2 cursor position
+XSCR RMB 2 disc screen being accessed ( O=terminal )
+XOFSET RMB 2 disc sector offset for multi-disc
+XCONT RMB 2 last word in primary search vocabulary
+XCURR RMB 2 last word in extensible vocabulary
+XSTATE RMB 2 flag for 'interpret' or 'compile' modes
+XBASE RMB 2 number base for I/O numeric conversion
+XDPL RMB 2 decimal point place
+XFLD RMB 2
+XCSP RMB 2 current stack position, for compile checks
+XRNUM RMB 2
+XHLD RMB 2
+XDELAY RMB 2 carriage return delay count
+XCOLUM RMB 2 carriage width
+IOSTAT RMB 2 last acia status from write/read
+ RMB 2 ( 4 spares! )
+ RMB 2
+ RMB 2
+ RMB 2
+
+
+
+
+*
+*
+* end of user table, start of common system variables
+*
+*
+*
+XUSE RMB 2
+XPREV RMB 2
+ RMB 4 ( spares )
+
+ PAGE
+* The FORTH program ( address $1200 to about $27FF ) will be written
+* so that it can be in a ROM, or write-protected if desired,
+* but right now we're just getting it running.
+ ORG CODEBG
+
+* ######>> screen 3 <<
+*
+***************************
+** C O L D E N T R Y **
+***************************
+ORIG NOP
+* JMP CENT
+ LBSR CENT
+***************************
+** W A R M E N T R Y **
+***************************
+ NOP
+* JMP WENT warm-start code, keeps current dictionary intact
+ LBSR WENT warm-start code, keeps current dictionary intact
+ SETDP IUPDP
+
+*
+******* startup parmeters **************************
+*
+ FDB $6809,0000 cpu & revision
+ FDB 0 topmost word in FORTH vocabulary
+* BACKSP FDB $7F backspace character for editing
+BACKSP FDB $08 backspace character for editing
+UPINIT FDB UORIG initial user area
+* UPINIT FDB UORIG initial user area
+SINIT FDB ISP ; initial top of data stack
+* SINIT FDB ORIG-$D0 initial top of data stack
+RINIT FDB IRP ; initial top of return stack
+* RINIT FDB ORIG-2 initial top of return stack
+ FDB ITIB ; terminal input buffer
+* FDB ORIG-$D0 terminal input buffer
+ FDB 31 initial name field width
+ FDB 0 initial warning mode (0 = no disc)
+FENCIN FDB REND initial fence
+DPINIT FDB REND cold start value for DICTPT
+BUFINT FDB BUFBAS Start of the disk buffers area
+VOCINT FDB FORTH+4*NATWID
+COLINT FDB TIBSZ initial terminal carriage width
+DELINT FDB 4 initial carriage return delay
+****************************************************
+*
+ PAGE
+*
+* ######>> screen 13 <<
+* These were of questionable use anyway,
+* kept here now to satisfy the assembler and show hints.
+* They're too much trouble to use with native subroutine call anyway.
+* PULABX PULS A ; 24 cycles until 'NEXT'
+* PULS B ;
+* PULABX PULU A,B ; ?? cycles until 'NEXT'
+* STABX STA 0,X 16 cycles until 'NEXT'
+* STB 1,X
+* STABX STD 0,X ; ?? cycles until 'NEXT'
+ BRA NEXT
+* GETX LDA 0,X 18 cycles until 'NEXT'
+* LDB 1,X
+* GETX LDD 0,X ?? cycles until 'NEXT'
+* PUSHBA PSHS B ; 8 cycles until 'NEXT'
+* PSHS A ;
+* PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
+
+
+*
+* "NEXT" takes ?? cycles if TRACE is removed,
+*
+* and ?? cycles if trace is present and NOT tracing.
+*
+* = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
+* =
+* NEXT itself might just completely go away.
+* About the only reason to keep it is to allowing executing a list
+* which allows a cheap TRACE routine.
+*
+* NEXT is a loop which implements the Forth VM.
+* It basically cycles through calling the code out of code lists,
+* one at a time.
+* Using a native CPU return for this uses a few extra cycles per call,
+* compared to simply jumping to each definition and jumping back
+* to the known beginning of the loop,
+* but the loop itself is really only there for convenience.
+*
+* This implementation uses the native subroutine call,
+* to break the wall between Forth code and non-Forth code.
+*
+* NEXT LDX IP
+* LEAX 1,X ; pre-increment mode
+* LEAX 1,X ;
+* STX IP
+NEXT ; IP is Y, push before using, pull before you come back here.
+*
+* NEXT2 LDX 0,X get W which points to CFA of word to be done
+NEXT2 LDX ,Y++ get W which points to CFA of word to be done
+* BSR DBGNAM
+* BSR DBGREG
+* But NEXT2 is too much trouble to use with subroutine threading anyway.
+* NEXT3 STX W
+NEXT3 ; W is X until you use X for something else. (TOS points back here.)
+* But NEXT3 is too much trouble to use with subroutine threading anyway.
+* LDX 0,X get VECT which points to executable code
+* =
+* The next instruction could be patched to JMP TRACE =
+* if a TRACE routine is available: =
+* =
+* JMP 0,X
+
+ JSR [,X] ; Saving the postinc cycles,
+* ; but X must be bumped NATWID to the parameters.
+* NOP
+* JMP TRACE ( an alternate for the above )
+* BSR DBGREG ( an alternate for the above )
+* In other words, with the call and the NOP,
+* there is room to patch the call with a JMP to your TRACE
+* routine, which you have to provide.
+ BRA NEXT
+*
+DBGNAM PSHS CC,D,X,Y
+ TST <TRACEM
+ BEQ DBGNrt
+ LEAX -3,X
+DBGNlf LDB ,-X
+ BPL DBGNlf
+ LDY #$4C0
+ LDB ,X+
+DBGNlp LDB ,X+
+ BMI DBGNll
+ STB ,Y+
+ BRA DBGNlp
+DBGNll ANDB #$7F
+ STB ,Y+
+ LDB #$60
+ BRA DBGNlt
+DBGNlc STB ,Y+
+DBGNlt CMPY #$4E0
+ BLO DBGNlc
+DBGNrt PULS CC,D,X,Y,PC
+*
+*
+MKhxBh LSRB
+ LSRB
+ LSRB
+ LSRB
+MKhxBl ANDB #$0F
+ ADDB #$30
+ CMPB #$39
+ BLS MKhxBx
+ ADDB #$C7 ; ($40-$39)-$40
+MKhxBx RTS
+*
+OUThxA EXG A,B
+ BSR OUThxB
+ EXG A,B
+ RTS
+*
+OUThxD BSR OUThxA
+OUThxB PSHS B
+ BSR MKhxBh
+ STB ,X+
+ LDB ,S
+ BSR MKhxBl
+ STB ,X+
+ PULS B,PC
+*
+DBGREG PSHS U,Y,X,DP,B,A,CC
+ TST <TRACEM
+ LBEQ DBGRrt
+ LEAY DBGRLB,PCR
+ LDX #$4E0
+DBGRlp LDD ,Y++
+ BEQ DBGRdn
+ STD ,X++
+ BRA DBGRlp
+DBGRdn LDX #$500
+ LDA 3,S ; DP
+ LDB ,S ; CC
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 3*NATWID+4,S ; PC:505
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ TFR S,D ; 509
+ ADDD #4*NATWID+4
+ BSR OUThxD
+ LDD 2*NATWID+4,S ; U:50E
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 1*NATWID+4,S ; Y:513
+ BSR OUThxD
+ LDD 0*NATWID+4,S ; X at 517
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 1,S ; D at 51C
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ LDD [3*NATWID+4,S] ; PC
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 4*NATWID+4,S ; S
+ BSR OUThxD
+ LDD [2*NATWID+4,S] ; U
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD [1*NATWID+4,S] ; Y
+ LBSR OUThxD
+ LDD [0*NATWID+4,S] ; X
+ LBSR OUThxD
+ LDB #$60
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ LDB #0
+ EXG B,DP
+DBGRkl JSR [$A000]
+ BEQ DBGRkl
+ STD $43E
+ EXG DP,B
+ CMPA #$55 ; 'U'
+ BEQ DBGRdU
+ CMPA #$53 ; 'S'
+ BEQ DBGRdS
+ CMPA #$49 ; 'I'
+ BNE DBGRrt
+DBGRin LDD <XTIB
+ ADDD <XIN
+ TFR D,Y
+ LBSR OUThxD
+ LDB #$3a ; ':'
+ STB ,X+
+ LDA <XCOLUM
+DBGRip LDB ,Y+
+ STB ,X+
+ BEQ DBGRrt
+DBGRit DECA
+ BNE DBGRip
+ BRA DBGRrt
+DBGRdS TFR S,Y
+ BRA DBGRst
+DBGRsp LDD ,Y++
+ LBSR OUThxD
+ LDB #$60
+ STB ,X+
+DBGRst CMPY <XRZERO
+ BLO DBGRsp
+ LDB #$3a ; ':'
+ STB ,X+
+ LDB #$55
+ STB ,X+
+DBGRdU LDY 2*NATWID+4,S
+ BRA DBGRut
+DBGRup LDD ,Y++
+ LBSR OUThxD
+ LDB #$60
+ STB ,X+
+DBGRut CMPY <XSPZER
+ BLO DBGRup
+DBGRrt PULS CC,A,B,DP,X,Y,U,PC
+DBGRLB FCC 'DPCC PC S U Y X A B '
+ FDB 0,0
+
+
+*
+* =
+* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+
+
+ PAGE
+*
+* ======>> 1 <<
+* ( --- n )
+* Pushes the following natural width integer from the instruction stream
+* as a literal, or immediate value.
+*
+* FDB {OP}
+* FDB {OP}
+* FDB LIT
+* FDB LITERAL-TO-BE-PUSHED
+* FDB {OP}
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* (Note that there is no compile-only flag in the fig model.)
+*
+* See (FIND), or PFIND , for layout of the header format.
+*
+ FCB $83
+ FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
+ FCB $D4 ; 'T'|'\x80' ; character code for T, with high bit set.
+ FDB 0 ; link of zero to terminate dictionary scan
+LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
+ LDD ,Y++
+ PSHU A,B
+ RTS
+* LDX IP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX IP
+* LDA 0,X
+* LDB 1,X
+* JMP PUSHBA
+*
+* ######>> screen 14 <<
+* ======>> 2 <<
+* ( --- n )
+* Pushes the following byte from the instruction stream
+* as a literal, or immediate value.
+*
+* FDB {OP}
+* FDB {OP}
+* FDB LIT8
+* FCB LITERAL-TO-BE-PUSHED
+* FDB {OP}
+*
+* If this is kept, it should have a header for TRACE to read.
+* If the data bus is wider than a byte, you don't want to do this.
+* Byte shaving like this is often counter-productive anyway.
+* Changing the name to LIT8, hoping that will be more understandable.
+* Also, see comments for LIT.
+* (Note that there is no compile-only flag in the fig model.)
+ FCB $84
+ FCC 'LIT' ; 'LIT8' : NOTE: this is different from LITERAL
+ FCB $B8
+ FDB LIT-6
+LIT8 FDB *+NATWID (this was an invisible word, with no header)
+ LDB ,Y+ ; This also is meaningless in native code.
+ CLRA
+ PSHU A,B
+ RTS
+* LDX IP
+* LEAX 1,X ;
+* STX IP
+* CLRA ;
+* LDB 1,X
+* JMP PUSHBA
+*
+* ( n off --- n )
+* off is offset in video buffer area.
+ FCB $87
+ FCC 'SHOWTO' ; 'SHOWTOS'
+ FCB $D3 ; 'S'
+ FDB LIT8-7
+SHOTOS FDB *+NATWID
+ LDX #$400
+ LDD ,U++
+ LEAX D,X
+ LDD ,U
+ LBSR OUThxD
+ RTS
+*
+ FCB $85
+ FCC 'TROF' ; 'TROFF'
+ FCB $C6 ; 'F'|$80
+ FDB SHOTOS-10
+TROFF FDB *+NATWID
+ CLR <TRACEM
+ RTS
+*
+ FCB $84
+ FCC 'TRO' ; 'TRON'
+ FCB $CE ; 'N'|$80
+ FDB TROFF-8
+TRON FDB *+NATWID
+ INC <TRACEM
+ RTS
+*
+* ======>> 3 <<
+* ( adr --- )
+* Jump to address on stack. Used by the "outer" interpreter to
+* interactively invoke routines.
+* Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
+ FCB $87
+ FCC 'EXECUT' ; 'EXECUTE'
+ FCB $C5
+ FDB TRON-7
+EXEC FDB *+NATWID
+ PULU X ; Gotta have W anyway, just in case.
+ JMP [,X] ; Tail return.
+* TFR S,X ; TSX :
+* LDX 0,X get code field address (CFA)
+* LEAS 1,S ; pop stack
+* LEAS 1,S ;
+* JMP NEXT3
+*
+* ######>> screen 15 <<
+* ======>> 4 <<
+* ( --- ) C
+* Add the following word from the instruction stream to the
+* instruction pointer (Y++). Causes a program branch in Forth code stream.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $86
+ FCC 'BRANC' ; 'BRANCH'
+ FCB $C8
+ FDB EXEC-10
+BRAN FDB ZBYES ; Go steal code in ZBRANCH
+
+* Moving code around to optimize the branch taking case in 0BRANCH.
+ZBNO LEAY NATWID,Y ; No branch.
+ RTS
+* ======>> 5 <<
+* ( f --- ) C
+* BRANCH if flag is zero.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $87
+ FCC '0BRANC' ; '0BRANCH'
+ FCB $C8
+ FDB BRAN-9
+ZBRAN FDB *+NATWID
+ LDD ,U++
+ BNE ZBNO
+ZBYES LDD ,Y++
+ LEAY D,Y ; IP is postinc
+ RTS
+* PULS A ;
+* PULS B ;
+* PSHS B ; ** emulating ABA:
+* ADDA ,S+ ;
+* BNE ZBNO
+* BCS ZBNO
+* ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
+* LDB 3,X
+* LDA 2,X
+* ADDB IP+1
+* ADCA IP
+* STB IP+1
+* STA IP
+* JMP NEXT
+* ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
+* LEAX 1,X ; jump over branch delta
+* LEAX 1,X ;
+* STX IP
+* JMP NEXT
+*
+* ######>> screen 16 <<
+* ======>> 6 <<
+* ( --- ) ( limit index *** limit index+1) C
+* ( limit index *** )
+* Counting loop primitive. The counter and limit are the top two
+* words on the return stack. If the updated index/counter does
+* not exceed the limit, a branch occurs. If it does, the branch
+* does not occur, and the index and limit are dropped from the
+* return stack.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $86
+ FCC '(LOOP' ; '(LOOP)'
+ FCB $A9
+ FDB ZBRAN-10
+XLOOP FDB *+NATWID
+ LDD #1 ; Borrowing from BIF-6809.
+XLOOPA ADDD NATWID,S ; Dodge the return address.
+ STD NATWID,S
+ SUBD 2*NATWID,S
+ BLT ZBYES ; signed
+XLOOPN LEAY NATWID,Y
+ LDX ,S ; synthetic return
+ LEAS 3*NATWID,S ; Clean up the index and limit.
+ JMP ,X
+* CLRA ;
+* LDB #1 get set to increment counter by 1 (Clears N.)
+* BRA XPLOP2 go steal other guy's code!
+*
+* ======>> 7 <<
+* ( n --- ) ( limit index *** limit index+n ) C
+* ( limit index *** )
+* Loop with a variable increment. Terminates when the index
+* crosses the boundary from one below the limit to the limit. A
+* positive n will cause termination if the result index equals the
+* limit. A negative n must cause the index to become less than
+* the limit to cause loop termination.
+*
+* Note that the end conditions are not symmetric around zero.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $87
+ FCC '(+LOOP' ; '(+LOOP)'
+ FCB $A9
+ FDB XLOOP-9
+XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
+ LDD ,U++ ; inc val
+ BPL XLOOPA ; Steal plain loop code for forward count.
+ ADDD NATWID,S ; Dodge the return address
+ STD NATWID,S
+ SUBD 2*NATWID,S
+ BGT ZBYES ; signed
+ BRA XLOOPN ; This path is less time-sensitive.
+*
+* This should work, but I want to use tested code.
+* PULU A,B ; Get the increment.
+* XPLOP2 PULS X ; Pre-clear the return stack.
+* PSHU A ; Save the direction in high bit.
+* ADDD ,S ; Count.
+* STD ,S ; Update.
+* SUBD NATWID,S ; Check limit.
+**
+** I think this should work:
+* EORA ,U+ ; dir < 0 and (count - limit) >= 0
+* BPL XPLONO ; or dir >= 0 and (count - limit) < 0
+* LDD ,Y++
+* LEAY D,Y ; IP is postinc
+* JMP ,X
+* XPLONO LEAS 2*NATWID,S
+* JMP ,X ; synthetic return
+*
+* This definitely should work:
+* TST ,U+ ; Get the sign
+* BPL XPLOF ;
+* CMPD NATWID,S
+* BMI XPLONO
+* XPLOYE LDD ,Y++
+* LEAY D,Y ; IP is postinc
+* JMP ,X
+* XPLOF CMPD NATWID,S
+* BMI XPLOYE
+* XPLONO LEAS 2*NATWID,S
+* JMP ,X ; synthetic return
+*
+* 6800 Probably could have used the exclusive-or method, too.:
+* PULS A ; get increment
+* PULS B ;
+* XPLOP2 TSTA ;
+* BPL XPLOF forward looping
+* BSR XPLOPS
+* ORCC #$01 ; SEC :
+* SBCB 5,X
+* SBCA 4,X
+* BPL ZBYES
+* BRA XPLONO fall through
+*
+* the subroutine :
+* XPLOPS LDX RP
+* ADDB 3,X add it to counter
+* ADCA 2,X
+* STB 3,X store new counter value
+* STA 2,X
+* RTS
+*
+* XPLOF BSR XPLOPS
+* SUBB 5,X
+* SBCA 4,X
+* BMI ZBYES
+*
+* XPLONO LEAX 1,X ; done, don't branch back
+* LEAX 1,X ;
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX RP
+* BRA ZBNO use ZBRAN to skip over unused delta
+*
+* ######>> screen 17 <<
+* ======>> 8 <<
+* ( limit index --- ) ( *** limit index )
+* Move the loop parameters to the return stack. Synonym for D>R.
+ FCB $84
+ FCC '(DO' ; '(DO)'
+ FCB $A9
+ FDB XPLOOP-10
+XDO FDB *+NATWID This is the RUNTIME DO, not the COMPILING DO
+ LDX ,S ; Save the return address.
+ PULU A,B
+ PSHS A,B
+ PULU A,B ; Maintain order.
+ STD NATWID,S
+ JMP ,X ; synthetic return
+*
+* LDX RP
+* LEAX -1,X ;
+* LEAX -1,X ;
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* PULS A ;
+* PULS B ;
+* STA 2,X
+* STB 3,X
+* PULS A ;
+* PULS B ;
+* STA 4,X
+* STB 5,X
+* JMP NEXT
+*
+* ======>> 9 <<
+* ( --- index ) ( limit index *** limit index )
+* Copy the loop index from the return stack. Synonym for R.
+ FCB $81 I
+ FCB $C9
+ FDB XDO-7
+I FDB *+NATWID
+ LDD NATWID,S ; Dodge return address.
+ PSHU A,B
+ RTS
+* LDX RP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* JMP GETX
+*
+* ######>> screen 18 <<
+* ======>> 10 <<
+* ( c base --- false )
+* ( c base --- n true )
+* Translate C in base, yielding a translation valid flag. If the
+* translation is not valid in the specified base, only the false
+* flag is returned.
+ FCB $85
+ FCC 'DIGI' ; 'DIGIT'
+ FCB $D4
+ FDB I-4
+DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
+ LDD NATWID,U ; Check the whole thing.
+ SUBD #$30 ; ascii zero
+ BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+ CMPD #$A
+ BMI DIGIT0 IF '9' OR LESS
+ CMPD #$11
+ BMI DIGIT2 if less than 'A'
+ CMPD #$2B
+ BPL DIGIT2 if greater than 'Z'
+ SUBD #7 translate 'A' thru 'F'
+DIGIT0 CMPD ,U ; Check the base.
+ BPL DIGIT2 if not less than the base
+ STD NATWID,U ; Store converted digit. (High byte known zero.)
+ LDD #1 ; set valid flag
+DIGIT1 STD ,U ; store the flag
+ RTS NEXT
+DIGIT2 LDD #0 ; set not valid flag
+ LEAU NATWID,U ; pop base
+ BRA DIGIT1
+* TFR S,X ; TSX :
+* LDA 3,X
+* SUBA #$30 ascii zero
+* BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+* CMPA #$A
+* BMI DIGIT0 IF '9' OR LESS
+* CMPA #$11
+* BMI DIGIT2 if less than 'A'
+* CMPA #$2B
+* BPL DIGIT2 if greater than 'Z'
+* SUBA #7 translate 'A' thru 'F'
+* DIGIT0 CMPA 1,X
+* BPL DIGIT2 if not less than the base
+* LDB #1 set flag
+* STA 3,X store digit
+* DIGIT1 STB 1,X store the flag
+* JMP NEXT
+* DIGIT2 CLRB ;
+* LEAS 1,S ;
+* LEAS 1,S ; pop bottom number
+* TFR S,X ; TSX :
+* STB 0,X make sure both bytes are 00
+* BRA DIGIT1
+*
+* ######>> screen 19 <<
+*
+* The word definition format in the dictionary:
+*
+* (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
+*
+* NFA (name field address):
+* char-count + $80 Length of symbol name, flagged with high bit set.
+* char 1 Characters of symbol name.
+* char 2
+* ...
+* char n + $80 symbol termination flag (char set < 128 code points)
+* LFA (link field address):
+* link high byte \___pointer to previous word in list
+* link low byte / -- Combined allocation/dictionary list. --
+* CFA (code field address):
+* CFA high byte \___pointer to native CPU machine code
+* CFA low byte / -- Consider this the characteristic code. --
+* PFA (parameter field address):
+* parameter fields -- Machine code for low-level native machine CPU code,
+* " instruction list for high-level Forth code,
+* " constant data for constants, pointers to per task variables,
+* " space for variables, for global variables, etc.
+*
+* In the case of native CPU machine code, the address at CFA will be PFA.
+
+* Definition attributes:
+FIMMED EQU $40 ; Immediate word flag.
+FSMUDG EQU $20 ; Smudged => definition not ready.
+CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte.
+* Note that the SMUDGE bit is not masked out.
+*
+* But we really want more (Thinking for a new model, need one more byte):
+* FCOMPI EQU $10 ; Compile-time-only.
+* FASSEM EQU $08 ; Assembly-language code only.
+* F4THLV EQU $04 ; Must not be called from assembly language code.
+* These would require some significant adjustments to the model.
+* We also want to put the low-level VM stuff in its own vocabulary.
+*
+* ======>> 11 <<
+* (FIND) ( name vocptr --- locptr length true )
+* ( name vocptr --- false )
+* Search vocabulary for a symbol called name.
+* name is a pointer to a high-bit bracket string with length head.
+* vocptr is a pointer to the NFA of the tail-end (LATEST) definition
+* in the vocabulary to be searched.
+* Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
+ FCB $86
+ FCC '(FIND' ; '(FIND)'
+ FCB $A9
+ FDB DIGIT-8
+PFIND FDB *+NATWID
+ PSHS Y ; Have to track two pointers.
+* Use the stack and registers instead of temp area N.
+PA0 EQU NATWID ; pointer to the length byte of name being searched against
+PD EQU 0 ; pointer to NFA of dict word being checked
+*
+* INC <TRACEM
+* LBSR DBGREG
+ LDX PD,U ; Start in on the vocabulary (NFA).
+PFNDLP LDY PA0,U ; Point to the name to check against.
+ LDB ,X+ ; get dict name length byte
+ TFR B,A ; Save it in case it matches.
+ ANDB #CTMASK
+* LBSR DBGREG
+ CMPB ,Y+ ; Compare lengths
+* LBSR DBGREG
+ BNE PFNDUN
+PFNDBR LDB ,X+
+ TSTB ; ; Is high bit of character in dictionary entry set?
+* LBSR DBGREG
+ BPL PFNDCH
+* LBSR DBGREG
+ ANDB #$7F ; Clear high bit from dictionary.
+ CMPB ,Y+ ; Compare "last" characters.
+* LBSR DBGREG
+ BEQ FOUND ; Matches even if dictionary actual length is shorter.
+PFNDLN LDX ,X++ ; Get previous link in vocabulary.
+* LBSR DBGREG
+ BNE PFNDLP ; Continue if link not=0
+*
+* not found :
+ LEAU NATWID,U ; Return only false flag.
+ LDD #0
+ STD ,U
+* LBSR DBGREG
+* DEC <TRACEM
+ PULS Y,PC
+*
+PFNDCH CMPB ,Y+ ; Compare characters.
+* LBSR DBGREG
+ BEQ PFNDBR
+PFNDUN
+PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
+* LBSR DBGREG
+ BPL PFNDSC
+* LBSR DBGREG
+ BRA PFNDLN
+*
+* found :
+*
+FOUND LEAX 2*NATWID,X
+* LBSR DBGREG
+ STX NATWID,U
+ TFR A,B
+ CLRA
+ STD ,U
+* LBSR DBGREG
+ LDB #1
+ PSHU A,B
+* LBSR DBGREG
+* DEC <TRACEM
+ PULS Y,PC
+*
+* 6800 model:
+* NOP ; Probably leftovers from a debugging session.
+* NOP
+* PD EQU N ptr to dict word being checked
+* PA0 EQU N+2
+* PA EQU N+4
+* PC EQU N+6
+* LDX #PD
+* LDB #4
+* PFIND0 PULS A ; loop to get arguments
+* STA 0,X
+* LEAX 1,X ;
+* DECB ;
+* BNE PFIND0
+*
+* LDX PD
+* PFNDLP LDB 0,X get count dict count
+* STB PC
+* ANDB #$3F
+* LEAX 1,X ;
+* STX PD update PD
+* LDX PA0
+* LDA 0,X get count from arg
+* LEAX 1,X ;
+* STX PA intialize PA
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ; compare lengths
+* BNE PFNDUN
+* PFNDBR LDX PA
+* LDA 0,X
+* LEAX 1,X ;
+* STX PA
+* LDX PD
+* LDB 0,X
+* LEAX 1,X ;
+* STX PD
+* TSTB ; is dict entry neg. ?
+* BPL PFNDCH
+* ANDB #$7F clear sign
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ;
+* BEQ FOUND
+* PFNDLN LDX 0,X get new link
+* BNE PFNDLP continue if link not=0
+*
+* not found :
+*
+* CLRA ;
+* CLRB ;
+* JMP PUSHBA
+* PFNDCH PSHS B ; ** emulating CBA:
+* CMPA ,S+ ;
+* BEQ PFNDBR
+* PFNDUN LDX PD
+* PFNDSC LDB 0,X scan forward to end of this name
+* LEAX 1,X ;
+* BPL PFNDSC
+* BRA PFNDLN
+*
+* found :
+*
+* FOUND LDA PD compute CFA
+* LDB PD+1
+* ADDB #4
+* ADCA #0
+* PSHS B ;
+* PSHS A ;
+* LDA PC
+* PSHS A ;
+* CLRA ;
+* PSHS A ;
+* LDB #1
+* JMP PUSHBA
+*
+* PSHS A ; Left over from a stray copy-paste, I guess.
+* CLRA ;
+* PSHS A ;
+* LDB #1
+* JMP PUSHBA
+*
+* ######>> screen 20 <<
+* ======>> 12 <<
+* ( buffer ch --- buffer symboloffset delimiteroffset scancount )
+* ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
+* ( buffer ch --- buffer nuloffset onepast scancount )
+* Scan buffer for a symbol delimited by ch or ASCII NUL,
+* return the length of the buffer region scanned,
+* the offset to the trailing delimiter,
+* and the offset of the first character of the symbol.
+* Leave the buffer on the stack.
+* Scancount is also offset to first character not yet looked at.
+* If no symbol in buffer, scancount and symboloffset point to NUL
+* and delimiteroffset points one beyond for some reason.
+* On trailing NUL, delimiteroffset == scancount.
+* (Buffer is the address of the buffer array to scan.)
+* (This is a bit too tricky, really.)
+ FCB $87
+ FCC 'ENCLOS' ; 'ENCLOSE'
+ FCB $C5
+ FDB PFIND-9
+ENCLOS FDB *+NATWID
+ LDA 1,U ; Delimiter character to match against in A.
+ LDX NATWID,U ; Buffer to scan in.
+ CLRB ; Initialize offset. (Buffer < 256 wide!)
+* Scan to a non-delimiter or a NUL
+ENCDEL TST B,X ; NUL ?
+ BEQ ENCNUL
+ CMPA B,X ; Delimiter?
+ BNE ENC1ST
+ INCB ; count character
+ BRA ENCDEL
+* Found first character. Save the offset.
+ENC1ST STB 1,U ; Found first non-delimiter character --
+ CLR ,U ; store the count, zero high byte.
+* Scan to a delimiter or a NUL
+ENCSYM TST B,X ; NUL ?
+ BEQ ENC0TR
+ CMPA B,X ; delimiter?
+ BEQ ENCEND
+ INCB
+ BRA ENCSYM
+* Found end of symbol. Push offset to delimiter found.
+ENCEND CLRA ; high byte -- buffer < 255 wide!
+ PSHU A,B ; Offset to seen delimiter.
+* Advance and push address of next character to check.
+ ADDD #1 ; In case offset was 255.
+ PSHU A,B
+ RTS
+* Found NUL before non-delimiter, therefore there is no word
+ENCNUL CLRA ; high byte -- buffer < 255 wide!
+ STD ,U ; offset to NUL.
+ ADDD #1 ; Point after NUL to allow (FIND) to match it.
+ PSHU A,B ;
+ SUBD #1 ; Next is not passed NUL.
+ PSHU A,B ; Stealing code will save only one byte.
+ RTS
+* Found NUL following the word instead of delimiter.
+ENC0TR
+* INC <TRACEM
+* LBSR DBGREG
+ CLRA
+ PSHU A,B ; Save offset to first after symbol (NUL)
+* LBSR DBGREG
+ PSHU A,B ; and count scanned.
+* LBSR DBGREG
+* DEC <TRACEM
+ RTS
+* NOTE :
+* FC means offset (bytes) to First Character of next word
+* EW " " to End of Word
+* NC " " to Next Character to start next enclose at
+* ENCLOS FDB *+NATWID
+* LEAS 1,S ;
+* PULS B ; now, get the low byte, for an 8-bit delimiter
+* TFR S,X ; TSX :
+* LDX 0,X
+* CLR N
+* * wait for a non-delimiter or a NUL
+* ENCDEL LDA 0,X
+* BEQ ENCNUL
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ; CHECK FOR DELIM
+* BNE ENC1ST
+* LEAX 1,X ;
+* INC N
+* BRA ENCDEL
+* * found first character. Push FC
+* ENC1ST LDA N found first char.
+* PSHS A ;
+* CLRA ;
+* PSHS A ;
+* wait for a delimiter or a NUL
+* ENCSYM LDA 0,X
+* BEQ ENC0TR
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ; ckech for delim.
+* BEQ ENCEND
+* LEAX 1,X ;
+* INC N
+* BRA ENCSYM
+* * found EW. Push it
+* ENCEND LDB N
+* CLRA ;
+* PSHS B ;
+* PSHS A ;
+* * advance and push NC
+* INCB ;
+* JMP PUSHBA
+* found NUL before non-delimiter, therefore there is no word
+* ENCNUL LDB N found NUL
+* PSHS B ;
+* PSHS A ;
+* INCB ;
+* BRA ENC0TR+2 ; ********** POTENTIAL BUG HERE *******
+* ******** Should use labels in case opcodes change! ********
+* found NUL following the word instead of SPACE
+* ENC0TR LDB N
+* PSHS B ; save EW
+* PSHS A ;
+* ENCL8 LDB N save NC
+* JMP PUSHBA
+
+ PAGE
+*
+* ######>> screen 21 <<
+* The next 4 words call system dependant I/O routines
+* which are listed after word "-->" ( lable: "arrow" )
+* in the dictionary.
+*
+* ======>> 13 <<
+* ( c --- )
+* Write c to the output device (screen or printer).
+* ROM Uses the ECB device number at address $6F,
+* -2 is printer, 0 is screen.
+ FCB $84
+ FCC 'EMI' ; 'EMIT'
+ FCB $D4
+ FDB ENCLOS-10
+EMIT FDB *+NATWID
+ PULU D
+ LBSR PEMIT ; PEMIT expects the character in D.
+ INC <XOUT+1
+ BNE EMITDN
+ INC <XOUT
+EMITDN RTS
+* PULS A ;
+* PULS A ;
+* JSR PEMIT
+* LDX UP
+* INC XOUT+1-UORIG,X
+* BNE *+4 ;
+* ****WARNING**** HARD OFFSET: *+4 ****
+* INC XOUT-UORIG,X
+* JMP NEXT
+*
+* ======>> 14 <<
+* ( --- c )
+* ( --- BREAK )
+* Wait for a key from the keyboard.
+* If the key is BREAK, set the high byte (result $FF03).
+ FCB $83
+ FCC 'KE' ; 'KEY'
+ FCB $D9
+ FDB EMIT-7
+KEY FDB *+NATWID
+ LBSR PKEY ; PKEY leaves the key/break code in D.
+ PSHU D
+ RTS
+* JSR PKEY
+* PSHS A ;
+* CLRA ;
+* PSHS A ;
+* JMP NEXT
+*
+* ======>> 15 <<
+* ( --- f )
+* Scan keyboard, but do not wait.
+* Return 0 if no key,
+* BREAK ($ff03) if BREAK is pressed,
+* or key currently pressed.
+ FCB $89
+ FCC '?TERMINA' ; '?TERMINAL'
+ FCB $CC
+ FDB KEY-6
+QTERM FDB *+NATWID
+ LBSR PQTER ; PQTER leaves the flag/key in D.
+ PSHU D
+ RTS
+* JSR PQTER
+* CLRB ;
+* JMP PUSHBA stack the flag
+*
+* ======>> 16 <<
+* ( --- )
+* EMIT a Carriage Return (ASCII CR).
+ FCB $82
+ FCC 'C' ; 'CR'
+ FCB $D2
+ FDB QTERM-12
+CR FDB *+NATWID
+ LBRA PCR ; Nothing really to do here.
+* JSR PCR
+* JMP NEXT
+*
+* ######>> screen 22 <<
+* ======>> 17 <<
+* ( source target count --- )
+* Copy/move count bytes from source to target.
+* Moves ascending addresses,
+* so that overlapping only works if the source is above the destination.
+ FCB $85
+ FCC 'CMOV' ; 'CMOVE' : source, destination, count
+ FCB $C5
+ FDB CR-5
+CMOVE FDB *+NATWID
+* Another way ; takes ( 42+17*count+9*(count/256) cycles )
+ LDD #0 ; #3~3
+ SUBD ,U++ ; #2~9 ; invert the count
+ PSHS A,Y ; #2~8
+ PULU X,Y ; #2~9
+ BEQ CMOVEX ; #2~3
+CMOVEL
+ LDA ,Y+ ; #2~6
+ STA ,X+ ; #2~6
+ INCB ; #1~2
+ BNE CMOVEL ; #2~3
+ INC ,S ; #2~6
+ BNE CMOVEL ; #2~3
+CMOVEX PULS A,Y,PC ; #2~10
+* PSHS Y ;
+* INC <TRACEM
+* LBSR DBGREG
+* LDX 1*NATWID,U
+* LDY 2*NATWID,U
+* BRA CMOVLE ;
+* CMOVLP
+* LBSR DBGREG
+* LDA ,Y+
+* STA ,X+
+* LBSR DBGREG
+* CMOVLE
+* LDD ,U
+* SUBD #1
+* STD ,U
+* BCC CMOVLP
+* LEAU 3*NATWID,U
+* DEC <TRACEM
+* PULS Y,PC
+* One way: ; takes ( 37+17*count+9*(count/256) cycles )
+* PSHS Y ; #2~7 ; Gotta have our pointers.
+* INC <TRACEM
+* LBSR DBGREG
+* PULU D,X,Y ; #2~11
+* PSHS A ; #2~6 ; Gotta have our pointers.
+* BRA CMOVLE ; #2~3
+* CMOVLP
+* LBSR DBGREG
+* LDA ,Y+ ; #2~6
+* STA ,X+ ; #2~6
+* LBSR DBGREG
+* CMOVLE
+* SUBB #1 ; #2~2
+* BCC CMOVLP ; #2~3
+* DEC ,S ; #2=6
+* BPL CMOVLP ; #2~3 ; If this actually works, it is limited to 32k here.
+* DEC <TRACEM
+* PULS A,Y,PC ; #2~10
+* Yet another way ; takes ( 37+29*count cycles )
+* PSHS Y ; #2~7
+* LDX NATWID,U ; #2~6
+* LDY NATWID,U ; #3~7
+* BRA CMOVLE ; #2~3
+* CMOVLP
+* LDA ,Y+ ; #2~6
+* STA ,X+ ; #2~6
+* CMOVLE
+* LDD ,U ; #2~5
+* SUBD #1 ; #3~4
+* STD ,U ; #2~5
+* BPL CMOVLP ; #2~3
+* LEAU 3*NATWID,U ; #2~5
+* PULS Y,PC ; #2~9
+* Yet another way ; takes ( 44+24*odd+33*count/2 cycles )
+* PSHS Y ; #2~7
+* LDX NATWID,U ; #2~6
+* LDY 2*NATWID,U ; #3~7
+* LDD ,U ; #2~5
+* BITB #1 ; #2~2
+* BEQ CMOVLE ; #2~3
+* SUBD #1 ; #3~4
+* STD ,U ; #2~5
+* LDA ,Y+ ; #2~6
+* STA ,X+ ; #2~6
+* BRA CMOVLE ; #2~3
+* CMOVLP
+* LDD ,Y++ ; #2~8
+* STD ,X++ ; #2~8
+* CMOVLI
+* LDD ,U ; #2~5
+* CMOVLE
+* SUBD #2 ; #3~4
+* STD ,U ; #2~5
+* BPL CMOVLP ; #2~3
+* LEAU 3*NATWID,U ; #2~5
+* PULS Y,PC ; #2~9
+* From the 6800 model:
+* CMOVE FDB *+2 takes ( 43+47*count cycles ) on 6800
+* LDX #N
+* LDB #6
+* CMOV1 PULS A ;
+* STA 0,X move parameters to scratch area
+* LEAX 1,X ;
+* DECB ;
+* BNE CMOV1
+* CMOV2 LDA N
+* LDB N+1
+* SUBB #1
+* SBCA #0
+* STA N
+* STB N+1
+* BCS CMOV3
+* LDX N+4
+* LDA 0,X
+* LEAX 1,X ;
+* STX N+4
+* LDX N+2
+* STA 0,X
+* LEAX 1,X ;
+* STX N+2
+* BRA CMOV2
+* CMOV3 JMP NEXT
+*
+* ######>> screen 23 <<
+* ======>> 18 <<
+* ( u1 u2 --- ud )
+* Multiplies the top two unsigned integers,
+* yielding a double integer product.
+ FCB $82
+ FCC 'U' ; 'U*'
+ FCB $AA
+ FDB CMOVE-8
+USTAR FDB *+NATWID
+ LEAU -2*NATWID,U
+ LDA 2*NATWID+1,U ; least
+ LDB 3*NATWID+1,U
+ MUL
+ STD NATWID,U
+ LDA 2*NATWID,U ; most
+ LDB 3*NATWID,U
+ MUL
+ STD ,U
+ LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi)
+ MUL
+ ADDD 1,U
+ BCC USTAR3
+ INC ,U
+USTAR3 STD 1,U
+ LDA 2*NATWID,U ; second inner (u2 hi)
+ LDB 3*NATWID,U ; (u1 lo)
+ MUL
+ ADDD 1,U
+ BCC USTAR4
+ INC ,U
+USTAR4 STD 1,U
+ PULU D,X
+ STD ,U
+ STX NATWID,U
+ RTS
+*
+* from 6800 model:
+* BSR USTARS
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP PUSHBA
+*
+* The following is a subroutine which
+* multiplies top 2 words on stack,
+* leaving 32-bit result: high order word in A,B
+* low order word in 2nd word of stack.
+*
+* USTARS LDA #16 bits/word counter
+* PSHS A ;
+* CLRA ;
+* CLRB ;
+* TFR S,X ; TSX :
+* USTAR2 ROR 5,X shift multiplier
+* ROR 6,X
+* DEC 0,X done?
+* BMI USTAR4
+* BCC USTAR3
+* ADDB 4,X
+* ADCA 3,X
+* USTAR3 RORA ;
+* RORB ; shift result
+* BRA USTAR2
+* USTAR4 LEAS 1,S ; dump counter
+* RTS
+*
+* ######>> screen 24 <<
+* ======>> 19 <<
+* ( ud u --- uremainder uquotient )
+* Divides the top unsigned integer
+* into the second and third words on the stack
+* as a single unsigned double integer,
+* leaving the remainder and quotient (quotient on top)
+* as unsigned integers.
+*
+* The smaller the divisor, the more likely dropping the high word
+* of the quotient loses significant bits. See M/MOD .
+*
+ FCB $82
+ FCC 'U' ; 'U/'
+ FCB $AF
+ FDB USTAR-5
+USLASH FDB *+NATWID
+ LDA #17 ; bit ct
+ PSHS A
+ LDD NATWID,U ; dividend
+USLDIV CMPD ,U ; divisor
+ BHS USLSUB
+ ANDCC #~1 ; carry clear
+ BRA USLBIT
+USLSUB SUBD ,U
+ ORCC #1 ; quotient, (carry set)
+USLBIT ROL 2*NATWID+1,U ; save it
+ ROL 2*NATWID,U
+ DEC ,S ; more bits?
+ BEQ USLR
+ ROLB ; remainder
+ ROLA
+ BCC USLDIV
+ BRA USLSUB
+USLR LEAU NATWID,U
+ LDX NATWID,U
+ STD NATWID,U
+ STX ,U
+ PULS A,PC ; Avoiding a LEAS 1,S by discarding A.
+*
+* from 6800 model:
+* LDA #17
+* PSHS A ;
+* TFR S,X ; TSX :
+* LDA 3,X
+* LDB 4,X
+* USL1 CMPA 1,X
+* BHI USL3
+* BCS USL2
+* CMPB 2,X
+* BCC USL3
+* USL2 ANDCC #~$01 ; CLC :
+* BRA USL4
+* USL3 SUBB 2,X
+* SBCA 1,X
+* ORCC #$01 ; SEC :
+* USL4 ROL 6,X
+* ROL 5,X
+* DEC 0,X
+* BEQ USL5
+* ROLB ;
+* ROLA ;
+* BCC USL1
+* BRA USL3
+* USL5 LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP SWAP+4 reverse quotient & remainder
+*
+* ######>> screen 25 <<
+* ======>> 20 <<
+* ( n1 n2 --- n )
+* Bitwise and the top two integers.
+ FCB $83
+ FCC 'AN' ; 'AND'
+ FCB $C4
+ FDB USLASH-5
+AND FDB *+NATWID
+ PULU A,B
+ ANDB 1,U
+ ANDA ,U
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* ANDB 1,X
+* ANDA 0,X
+* JMP STABX
+*
+* ======>> 21 <<
+* ( n1 n2 --- n )
+* Bitwise or the top two integers.
+ FCB $82
+ FCC 'O' ; 'OR'
+ FCB $D2
+ FDB AND-6
+OR FDB *+NATWID
+ PULU A,B
+ ORB 1,U
+ ORA ,U
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* ORB 1,X
+* ORA 0,X
+* JMP STABX
+*
+* ======>> 22 <<
+* ( n1 n2 --- n )
+* Bitwise exclusive or the top two integers.
+ FCB $83
+ FCC 'XO' ; 'XOR'
+ FCB $D2
+ FDB OR-5
+XOR FDB *+NATWID
+ PULU A,B
+ EORB 1,U
+ EORA ,U
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* EORB 1,X
+* EORA 0,X
+* JMP STABX
+*
+* ######>> screen 26 <<
+* ======>> 23 <<
+* ( --- adr )
+* Fetch the parameter stack pointer (before it is pushed).
+* This points at whatever was on the top of stack before.
+ FCB $83
+ FCC 'SP' ; 'SP@'
+ FCB $C0
+ FDB XOR-6
+SPAT FDB *+NATWID
+ TFR U,X
+ PSHU X
+ RTS
+* TFR S,X ; TSX :
+* STX N scratch area
+* LDX #N
+* JMP GETX
+*
+* ======>> 24 <<
+* ( whatever --- nothing )
+* Initialize the parameter stack pointer from the USER variable S0.
+* Effectively clears the stack.
+ FCB $83
+ FCC 'SP' ; 'SP!'
+ FCB $A1
+ FDB SPAT-6
+SPSTOR FDB *+NATWID
+ LDU <XSPZER
+ RTS
+* LDX UP
+* LDX XSPZER-UORIG,X
+* TFR X,S ; TXS : watch it ! X and S are not equal on 6800.
+* JMP NEXT
+* ======>> 25 <<
+* ( whatever *** nothing )
+* Initialize the return stack pointer from the initialization table
+* instead of the user variable R0, for some reason.
+* Quite possibly, this should be from R0.
+* Effectively aborts all in process definitions, except the active one.
+* An emergency measure, to be sure.
+* The routine that calls this must never execute a return.
+* So this should never be executed from the terminal, I guess.
+* This is another that should be compile-time only, and in a separate vocabulary.
+ FCB $83
+ FCC 'RP' ; 'RP!'
+ FCB $A1
+ FDB SPSTOR-6
+RPSTOR FDB *+NATWID
+ PULS X ; But this guy has to return to his caller.
+ LDS RINIT
+ JMP ,X
+* LDX RINIT initialize from rom constant
+* STX RP
+* JMP NEXT
+*
+* ======>> 26 <<
+* ( ip *** )
+* Pop IP from return stack (return from high-level definition).
+* Can be used in a screen to force interpretion to terminate.
+* Must not be executed when temporaries are saved on top of the return stack.
+ FCB $82
+ FCC ';' ; ';S'
+ FCB $D3
+ FDB RPSTOR-6
+SEMIS FDB *+NATWID
+ PULS D,Y ; return address in D, and saved IP in Y.
+ TFR D,PC ; Synthetic return.
+*
+* Form 6800 model:
+* LDX RP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX RP
+* LDX 0,X get address we have just finished.
+* JMP NEXT+2 increment the return address & do next word
+*
+* ######>> screen 27 <<
+* ======>> 27 <<
+* ( limit index *** index index )
+* Force the terminating condition for the innermost loop by
+* copying its index to its limit.
+* Termination is postponed until the next
+* LOOP or +LOOP instruction is executed.
+* The index remains available for use until
+* the LOOP or +LOOP instruction is encountered.
+* Note that the assumption is that the current count is the correct count
+* to end at, rather than pushing the count to the final count.
+ FCB $85
+ FCC 'LEAV' ; 'LEAVE'
+ FCB $C5
+ FDB SEMIS-5
+LEAVE FDB *+NATWID
+ LDD NATWID,S ; Dodge the return address.
+ STD 2*NATWID,S
+ RTS
+* LDX RP
+* LDA 2,X
+* LDB 3,X
+* STA 4,X
+* STB 5,X
+* JMP NEXT
+*
+* ======>> 28 <<
+* ( n --- )
+* ( *** n )
+* Move top of parameter stack to top of return stack.
+ FCB $82
+ FCC '>' ; '>R'
+ FCB $D2
+ FDB LEAVE-8
+TOR FDB *+NATWID
+ PULU A,B
+ LDX ,S
+ STD ,S ; Put it where the return address was.
+ JMP ,X
+* LDX RP
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* PULS A ;
+* PULS B ;
+* STA 2,X
+* STB 3,X
+* JMP NEXT
+*
+* ======>> 29 <<
+* ( --- n )
+* ( n *** )
+* Move top of return stack to top of parameter stack.
+ FCB $82
+ FCC 'R' ; 'R>'
+ FCB $BE
+ FDB TOR-5
+FROMR FDB *+NATWID
+ PULS D,X
+ PSHU X
+ TFR D,PC
+* LDX RP
+* LDA 2,X
+* LDB 3,X
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX RP
+* JMP PUSHBA
+*
+* ======>> 30 <<
+* ( --- n )
+* ( n *** n )
+* Copy the top of return stack to top of parameter stack.
+* A synonym for I.
+ FCB $81 R
+ FCB $D2
+ FDB FROMR-5
+R FDB I+NATWID
+
+* LDX RP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* JMP GETX
+*
+* ######>> screen 28 <<
+* ======>> 31 <<
+* ( n --- ~n )
+* Logically invert top of stack;
+* or flag true if top is zero, otherwise false.
+ FCB $83
+ FCC 'NO' ; 'NOT'
+ FCB $D4
+ FDB R-4
+LNOT FDB *+NATWID
+ COM 1,U
+ COM ,U
+ RTS
+* ( n --- n=0 )
+* Logically invert top of stack;
+* or flag true if top is zero, otherwise false.
+ FCB $82
+ FCC '0' ; '0='
+ FCB $BD
+ FDB LNOT-6
+ZEQU FDB *+NATWID
+ LDD #0
+ LDX ,U
+ BNE ZEQUF
+ INCB ; 1 is true
+ZEQUF STD ,U
+ RTS
+* TFR S,X ; TSX :
+* CLRA ;
+* CLRB ;
+* LDX 0,X
+* BNE ZEQU2
+* INCB ;
+*ZEQU2 TFR S,X ; TSX :
+* JMP STABX
+*
+* ======>> 32 <<
+* ( n --- n<0 )
+* Flag true if top is negative (MSbit set), otherwise false.
+ FCB $82
+ FCC '0' ; '0<'
+ FCB $BC
+ FDB ZEQU-5
+ZLESS FDB *+NATWID
+ LDD #0
+ TST ,U
+ BPL ZLESSF
+ INCB
+ZLESSF STD ,U
+ RTS
+* TFR S,X ; TSX :
+* LDA #$80 check the sign bit
+* ANDA 0,X
+* BEQ ZLESS2
+* CLRA ; if neg.
+* LDB #1
+* JMP STABX
+* ZLESS2 CLRB ;
+* JMP STABX
+*
+* ######>> screen 29 <<
+* ======>> 33 <<
+* ( n1 n2 --- n1+n2 )
+* Add top two words.
+ FCB $81 '+'
+ FCB $AB
+ FDB ZLESS-5
+PLUS FDB *+NATWID
+ PULU A,B ; #2~7
+ ADDD ,U ; #2~6
+ STD ,U ; #2~5
+ RTS ; #1~5 =#7~23
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* ADDB 1,X
+* ADCA 0,X
+* JMP STABX
+*
+* ======>> 34 <<
+* ( d1 d2 --- d1+d2 )
+* Add top two double integers.
+ FCB $82
+ FCC 'D' ; 'D+'
+ FCB $AB
+ FDB PLUS-4
+DPLUS FDB *+NATWID
+ LDD 3*NATWID,U
+ ADDD NATWID,U
+ STD 3*NATWID,U
+ LDD 2*NATWID,U
+ ADCB 1,U
+ ADCA ,U
+ LEAU 2*NATWID,U
+ STD ,U
+ RTS
+* TFR S,X ; TSX :
+* ANDCC #~$01 ; CLC :
+* LDB #4
+* DPLUS2 LDA 3,X
+* ADCA 7,X
+* STA 7,X
+* LEAX -1,X ;
+* DECB ;
+* BNE DPLUS2
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP NEXT
+*
+* ======>> 35 <<
+* ( n --- -n )
+* Negate (two's complement) top of stack.
+ FCB $85
+ FCC 'MINU' ; 'MINUS'
+ FCB $D3
+ FDB DPLUS-5
+MINUS FDB *+NATWID
+ LDD #0 ; #3~3
+ SUBD ,U ; #2~5
+ STD ,U ; #2~5
+ RTS ; #1~5 = #8~18
+*
+* from 6800 model code:
+* TFR S,X ; TSX :
+* NEG 1,X
+* BCC MINUS2
+* NEG 0,X
+* BRA MINUS3
+* MINUS2 COM 0,X
+* MINUS3 JMP NEXT
+*
+* ======>> 36 <<
+* ( d --- -d )
+* Negate (two's complement) top two words on stack as a double integer.
+ FCB $86
+ FCC 'DMINU' ; 'DMINUS'
+ FCB $D3
+ FDB MINUS-8
+DMINUS FDB *+NATWID
+ LDD #0 ; #3~3
+ SUBD NATWID,U ; #2~7
+ STD NATWID,U ; #2~7
+ LDD #0 ; #3~3
+ SBCB 1,U ; #2~5
+ SBCA ,U ; #2~4
+ STD ,U ; #2~5
+ RTS ; #1~5 = #17~39
+* TFR S,X ; TSX :
+* COM 0,X
+* COM 1,X
+* COM 2,X
+* NEG 3,X
+* BNE DMINX
+* INC 2,X
+* BNE DMINX
+* INC 1,X
+* BNE DMINX
+* INC 0,X
+* DMINX JMP NEXT
+*
+* ######>> screen 30 <<
+* ======>> 37 <<
+* ( n1 n2 --- n1 n2 n1 )
+* Push a copy of the second word on stack.
+ FCB $84
+ FCC 'OVE' ; 'OVER'
+ FCB $D2
+ FDB DMINUS-9
+OVER FDB *+NATWID
+ LDD NATWID,U
+ PSHU D
+ RTS
+* TFR S,X ; TSX :
+* LDA 2,X
+* LDB 3,X
+* JMP PUSHBA
+*
+* ======>> 38 <<
+* ( n --- )
+* Discard the top word on stack.
+ FCB $84
+ FCC 'DRO' ; 'DROP'
+ FCB $D0
+ FDB OVER-7
+DROP FDB *+NATWID
+ LEAU NATWID,U
+ RTS
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP NEXT
+*
+* ======>> 39 <<
+* ( n1 n2 --- n2 n1 )
+* Swap the top two words on stack.
+ FCB $84
+ FCC 'SWA' ; 'SWAP'
+ FCB $D0
+ FDB DROP-7
+SWAP FDB *+NATWID
+ PULU D,X
+ PSHU D
+ PSHU X
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* LDX 0,X
+* LEAS 1,S ;
+* LEAS 1,S ;
+* PSHS B ;
+* PSHS A ;
+* STX N
+* LDX #N
+* JMP GETX
+*
+* ======>> 40 <<
+* ( n1 --- n1 n1 )
+* Push a copy of the top word on stack.
+ FCB $83
+ FCC 'DU' ; 'DUP'
+ FCB $D0
+ FDB SWAP-7
+DUP FDB *+NATWID
+ LDD ,U
+ PSHU D
+ RTS
+* PULS A ;
+* PULS B ;
+* PSHS B ;
+* PSHS A ;
+* JMP PUSHBA
+*
+* ######>> screen 31 <<
+* ======>> 41 <<
+* ( n adr --- )
+* Add the second word on stack to the word at the adr on top of stack.
+ FCB $82
+ FCC '+' ; '+!'
+ FCB $A1
+ FDB DUP-6
+PSTORE FDB *+NATWID
+ PULU X
+ LDD ,X
+ ADDD ,U++
+ STD ,X
+ RTS
+* TFR S,X ; TSX :
+* LDX 0,X
+* LEAS 1,S ;
+* LEAS 1,S ;
+* PULS A ; get stack data
+* PULS B ;
+* ADDB 1,X add & store low byte
+* STB 1,X
+* ADCA 0,X add & store hi byte
+* STA 0,X
+* JMP NEXT
+*
+* ======>> 42 <<
+* ( adr b --- )
+* Exclusive or byte at adr with low byte of top word.
+ FCB $86
+ FCC 'TOGGL' ; 'TOGGLE'
+ FCB $C5
+ FDB PSTORE-5
+TOGGLE FDB *+NATWID
+ PULU D,X
+ EORB ,X
+ STB ,X
+ RTS
+* Using the model code would be less likely to introduce bugs,
+* but that would sort-of defeat my purposes here.
+* Anyway, I can borrow from theoretically known good bif-6809 code
+* and it's fewer bytes and much faster code this way.
+* TOGGLE
+* FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
+* FDB SEMIS
+*
+* ######>> screen 32 <<
+* ======>> 43 <<
+* ( adr --- n )
+* Replace address on stack with the word at the address.
+ FCB $81 @
+ FCB $C0
+ FDB TOGGLE-9
+AT FDB *+NATWID
+ LDD [,U]
+ STD ,U
+ RTS
+* TFR S,X ; TSX :
+* LDX 0,X get address
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP GETX
+*
+* ======>> 44 <<
+* ( adr --- b )
+* Replace address on top of stack with the byte at the address.
+* High byte of result is clear.
+ FCB $82
+ FCC 'C' ; 'C@'
+ FCB $C0
+ FDB AT-4
+CAT FDB *+NATWID
+ LDB [,U]
+ CLRA
+ STD ,U
+ RTS
+
+
+* TFR S,X ; TSX :
+* LDX 0,X
+* CLRA ;
+* LDB 0,X
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP PUSHBA
+*
+* ======>> 45 <<
+* ( n adr --- )
+* Store second word on stack at address on top of stack.
+ FCB $81
+ FCB $A1
+ FDB CAT-5
+STORE FDB *+NATWID
+ LDD NATWID,U
+ STD [,U]
+ LEAU 2*NATWID,U
+ RTS
+* TFR S,X ; TSX :
+* LDX 0,X get address
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP PULABX
+*
+* ======>> 46 <<
+* ( b adr --- )
+* Store low byte of second word on stack at address on top of stack.
+* High byte is ignored.
+ FCB $82
+ FCC 'C' ; 'C!'
+ FCB $A1
+ FDB STORE-4
+CSTORE FDB *+NATWID
+ LDB 3,U
+ STB [,U]
+ LEAU 2*NATWID,U
+ RTS
+* TFR S,X ; TSX :
+* LDX 0,X get address
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* PULS B ;
+* STB 0,X
+* JMP NEXT
+ PAGE
+*
+* ######>> screen 33 <<
+* ======>> 47 <<
+* ( --- ) P
+* { : name sundry-activities ; } typical input
+* If executing (not compiling),
+* record the data stack mark in CSP,
+* Set the CONTEXT vocabulary to CURRENT,
+* CREATE a header,
+* set state to compile,
+* and compile the call to the trailing native CPU machine code DOCOL.
+*
+* This would not be hard to flatten to native code.
+* But that's not the purpose of a model.
+ FCB $C1 : immediate
+ FCB $BA
+ FDB CSTORE-5
+COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
+ FDB CREATE,RBRAK
+ FDB PSCODE
+
+* Here is the IP pusher for allowing
+* nested words in the virtual machine:
+* ( ;S is the equivalent un-nester )
+
+* ( *** oldIP )
+* Characteristic of a colon (:) definition.
+* Begins execution of a high-level definition,
+* i. e., nests the definition and begins processing icodes.
+* Mechanically, it pushes the IP (Y register)
+* and loads the Parameter Field Address of the definition which
+* called it into the IP.
+DOCOL LDD ,S ; Save the return address.
+ STY ,S ; Nest the old IP.
+ LEAY NATWID,X ; W still in X, bump to parameters, load as new IP.
+ TFR D,PC ; synthetic return to interpret.
+
+* DOCOL LDX RP make room in the stack
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* LDA IP
+* LDB IP+1
+* STA 2,X Store address of the high level word
+* STB 3,X that we are starting to execute
+* LDX W Get first sub-word of that definition
+* JMP NEXT+2 and execute it
+*
+* ======>> 48 <<
+* ( --- ) P
+* { : name sundry-activities ; } typical input
+* ERROR check data stack against mark in CSP,
+* compile ;S,
+* unSMUDGE LATEST definition,
+* and set state to interpretation.
+ FCB $C1 ; imnediate code
+ FCB $BB
+ FDB COLON-4
+SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
+ FDB SEMIS
+*
+* ######>> screen 34 <<
+* ======>> 49 <<
+* ( n --- )
+* { value CONSTANT name } typical input
+* CREATE a header,
+* unSMUDGE it,
+* compile the constant value,
+* and compile the call to the trailing native CPU machine code DOCON.
+ FCB $88
+ FCC 'CONSTAN' ; 'CONSTANT'
+ FCB $D4
+ FDB SEMI-4
+CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
+* ( --- n )
+* Characteristic of a CONSTANT.
+* A CONSTANT simply loads its value from its parameter field
+* and pushes it on the stack.
+DOCON LDD NATWID,X ; Get the first natural width word of the parameter field.
+ PSHU D
+ RTS
+* DOCON LDX W
+* LDA 2,X
+* LDB 3,X A & B now contain the constant
+* JMP PUSHBA
+*
+* Not in model, needed for abstraction:
+* ( --- NATWID )
+* The byte width of objects on stack.
+ FCB $86
+ FCC 'NATWI' ; 'NATWID'
+ FCB $C4
+ FDB CON-11
+NATWC FDB DOCON
+NATWCV FDB NATWID
+*
+* Not in model, needed for abstraction:
+* Note that this is not defined as an INCREMENTER!
+* Coded to increment by the exact constant returned by NATWID
+* ( n --- n+NATWID )
+ FCB $84
+ FCC 'NAT' ; 'NAT+'
+ FCB $AB
+ FDB NATWC-9
+NATP FDB *+NATWID
+ LDD ,U
+ ADDD NATWCV,PCR ; Looking ahead, does not have to be PCRelative.
+ STD ,U
+ RTS
+* How this might have been done for 6800 model:
+* CLRA ; We know the natural width is less than 255, LOL.
+* LDAB NATWCV+1
+* TSX
+* ADDB 1,X
+* ADCA ,X
+* JMP STABX
+*
+* ======>> 50 <<
+* ( init --- )
+* { init VARIABLE name } typical input
+* Use CONSTANT to CREATE a header and compile the initial value, init,
+* then overwrite the characteristic to point to DOVAR.
+ FCB $88
+ FCC 'VARIABL' ; 'VARIABLE'
+ FCB $C5
+ FDB NATP-7
+VAR FDB DOCOL,CON,PSCODE
+* ( --- vadr )
+* Characteristic of a VARIABLE.
+* A VARIABLE pushes its PFA address on the stack.
+* The parameter field of a VARIABLE is the actual allocation of the variable,
+* so that pushing its address allows its contents to be @ed (fetched).
+* Ordinary arrays and strings that do not subscript themselves
+* may be allocated by defining a variable
+* and immediately ALLOTting the remaining needed space.
+* VARIABLES are global to all users,
+* and thus should be hidden in resource monitors, but aren't.
+DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters.
+ PSHU X
+ RTS
+* DOVAR LDA W
+* LDB W+1
+* ADDB #2
+* ADCA #0 A,B now contain the address of the variable
+* JMP PUSHBA
+*
+* ======>> 51 <<
+* ( ub --- )
+* { uboffset USER name } typical input
+* CREATE a header and compile the unsigned byte offset in the per-USER table,
+* then overwrite the header with a call to DOUSER.
+* The USER is entirely responsible for maintaining allocation!
+ FCB $84
+ FCC 'USE' ; 'USER'
+ FCB $D2
+ FDB VAR-11
+USER FDB DOCOL,CON,PSCODE
+* ( --- vadr )
+* Characteristic of a per-USER variable.
+* USER variables are similiar to VARIABLEs,
+* but are allocated (by hand!) in the per-user table.
+* A USER variable's parameter field contains its offset in the per-user table.
+DOUSER TFR DP,A ; Make a pointer to the direct page.
+ CLRB
+* See Alternative -- alternatives start from this point.
+ ADDD NATWID,X ; Add it to the offset to the per-user variable.
+ PSHU D
+ TFR D,X ; Cache the pointer in X for the caller.
+ RTS
+* Hey, the per-user table could actually be larger than 256 bytes!
+* But we knew that. It's just not as esthetic to calculate it this way.
+* Alternative A:
+* LDX NATWID,X ; Keep the offset
+* EXG D,X ; Prepare for EA
+* LEAX D,X
+* PSHU X
+* RTS
+* Alternative B:
+* PSHS Y ; Get Y free for calculations.
+* TFR D,Y ; Y points to the UP base
+* LDD NATWID,X ; Get the offset
+* LEAX D,Y ; Leave the pointer cached in X.
+* PSHU X
+* PULS Y,PC
+*
+* From the 6800 model:
+* DOUSER LDX W get offset into user's table
+* LDA 2,X
+* LDB 3,X
+* ADDB UP+1 add to users base address
+* ADCA UP
+* JMP PUSHBA push address of user's variable
+*
+* ######>> screen 35 <<
+* ======>> 52 <<
+* ( --- 0 )
+ FCB $81
+ FCB $B0 0
+ FDB USER-7
+ZERO FDB DOCON
+ FDB 0000
+*
+* ======>> 53 <<
+* ( --- 1 )
+ FCB $81
+ FCB $B1 1
+ FDB ZERO-4
+ONE FDB DOCON
+ONEV FDB 1
+*
+* ======>> 54 <<
+* ( --- 2 )
+ FCB $81
+ FCB $B2 2
+ FDB ONE-4
+TWO FDB DOCON
+TWOV FDB 2
+*
+* ======>> 55 <<
+* ( --- 3 )
+ FCB $81
+ FCB $B3 3
+ FDB TWO-4
+THREE FDB DOCON
+ FDB 3
+*
+* ======>> 56 <<
+* ( --- SP )
+* ASCII SPACE character
+ FCB $82
+ FCC 'B' ; 'BL'
+ FCB $CC
+ FDB THREE-4
+BL FDB DOCON ascii blank
+ FDB $20
+*
+* ======>> 57 <<
+* This really shouldn't be a CONSTANT.
+* ( --- adr )
+* The base of the disk buffer space.
+ FCB $85
+ FCC 'FIRS' ; 'FIRST'
+ FCB $D4
+ FDB BL-5
+FIRST FDB DOCON
+ FDB BUFBAS
+* FDB MEMEND-528 (132 * NBLK)
+*
+* ======>> 58 <<
+* This really shouldn't be a CONSTANT.
+* ( --- adr )
+* The limit of the disk buffer space.
+ FCB $85
+ FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
+ FCB $D4
+ FDB FIRST-8
+LIMIT FDB DOCON
+ FDB BUFBAS+BUFSZ
+* In 6800 model, was
+* FDB MEMEND
+*
+* ======>> 59 <<
+* ( --- sectorsize )
+* The size, in bytes, of a buffer control region.
+ FCB $85
+ FCC 'B/CT' ; 'B/CTL' : (bytes/control region)
+ FCB $CC
+ FDB LIMIT-8
+BCTL FDB DOCON
+ FDB SECTRL
+*
+* ( --- sectorsize )
+* The size, in bytes, of a buffer.
+ FCB $85
+ FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
+ FCB $C6
+ FDB BCTL-8
+BBUF FDB DOCON
+ FDB SECTSZ
+* Hardcoded in 6800 model:
+* FDB 128
+*
+* ======>> 60 <<
+* ( --- blocksperscreen )
+* The size, in blocks, of a screen.
+* Should this be the same as NBLK, the number of block buffers maintained?
+ FCB $85
+ FCC 'B/SC' ; 'B/SCR' : (blocks/screen)
+ FCB $D2
+ FDB BBUF-8
+BSCR FDB DOCON
+ FDB SCRSZ/SECTSZ
+* Hardcoded in 6800 model as:
+* FDB 8
+* blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
+*
+* ======>> 61 <<
+* ( n --- adr )
+* Calculate the address of entry (#n/2) in the boot-up parameter table.
+* (Adds the base of the boot-up table to n.)
+ FCB $87
+ FCC '+ORIGI' ; '+ORIGIN'
+ FCB $CE
+ FDB BSCR-8
+PORIG FDB DOCOL,LIT,ORIG,PLUS
+ FDB SEMIS
+*
+* ######>> screen 36 <<
+* ======>> 62 <<
+* ( n --- adr )
+* This is the per-task variable recording the initial parameter stack pointer.
+ FCB $82
+ FCC 'S' ; 'S0'
+ FCB $B0
+ FDB PORIG-10
+SZERO FDB DOUSER
+ FDB XSPZER-UORIG
+*
+* ======>> 63 <<
+* ( n --- adr )
+* This is the per-task variable recording the initial return stack pointer.
+ FCB $82
+ FCC 'R' ; 'R0'
+ FCB $B0
+ FDB SZERO-5
+RZERO FDB DOUSER
+ FDB XRZERO-UORIG
+*
+* ======>> 64 <<
+* ( --- vadr )
+* Terminal Input Buffer address.
+* Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
+ FCB $83
+ FCC 'TI' ; 'TIB'
+ FCB $C2
+ FDB RZERO-5
+TIB FDB DOUSER
+ FDB XTIB-UORIG
+*
+* ======>> 65 <<
+* ( --- maxnamewidth )
+* This is the maximum width to which symbol names will be recorded.
+ FCB $85
+ FCC 'WIDT' ; 'WIDTH'
+ FCB $C8
+ FDB TIB-6
+WIDTH FDB DOUSER
+ FDB XWIDTH-UORIG
+*
+* ======>> 66 <<
+* ( --- vadr )
+* Availability of error messages on disk.
+* Contains 1 if messages available,
+* 0 if not,
+* -1 if a disk error has occurred.
+ FCB $87
+ FCC 'WARNIN' ; 'WARNING'
+ FCB $C7
+ FDB WIDTH-8
+WARN FDB DOUSER
+ FDB XWARN-UORIG
+*
+* ======>> 67 <<
+* ( --- vadr )
+* Boundary for FORGET.
+ FCB $85
+ FCC 'FENC' ; 'FENCE'
+ FCB $C5
+ FDB WARN-10
+FENCE FDB DOUSER
+ FDB XFENCE-UORIG
+*
+* ======>> 68 <<
+* ( --- vadr )
+* Dictionary pointer, fetched by HERE.
+ FCB $82
+ FCC 'D' ; 'DP' : points to first free byte at end of dictionary
+ FCB $D0
+ FDB FENCE-8
+DICTPT FDB DOUSER
+ FDB XDICTP-UORIG
+*
+* ======>> 68.5 <<
+* ( --- vadr ) ******* Need to check what this is!
+* Used in maintaining vocabularies.
+* I think it points to the "parent" vocabulary, but I'm not sure.
+* Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
+ FCB $88
+ FCC 'VOC-LIN' ; 'VOC-LINK'
+ FCB $CB
+ FDB DICTPT-5
+VOCLIN FDB DOUSER
+ FDB XVOCL-UORIG
+*
+* ======>> 69 <<
+* ( --- vadr )
+* Disk block being interpreted.
+* Zero refers to terminal.
+* ******** Should be made a 32 bit user variable! ********
+* But the base system needs to have full 32 bit support, div and mul, etc.
+* before we can do that.
+ FCB $83
+ FCC 'BL' ; 'BLK'
+ FCB $CB
+ FDB VOCLIN-11
+BLK FDB DOUSER
+ FDB XBLK-UORIG
+*
+* ======>> 70 <<
+* ( --- vadr )
+* Input buffer offset/cursor.
+ FCB $82
+ FCC 'I' ; 'IN' : scan pointer for input line buffer
+ FCB $CE
+ FDB BLK-6
+IN FDB DOUSER
+ FDB XIN-UORIG
+*
+* ======>> 71 <<
+* ( --- vadr )
+* Output buffer offset/cursor.
+ FCB $83
+ FCC 'OU' ; 'OUT'
+ FCB $D4
+ FDB IN-5
+OUT FDB DOUSER
+ FDB XOUT-UORIG
+*
+* ======>> 72 <<
+* ( --- vadr )
+* Screen currently being edited, once we have an editor running.
+ FCB $83
+ FCC 'SC' ; 'SCR'
+ FCB $D2
+ FDB OUT-6
+SCR FDB DOUSER
+ FDB XSCR-UORIG
+* ######>> screen 37 <<
+*
+* ======>> 73 <<
+* ( --- vadr )
+* Sector offset for LOADing screens,
+* set by DRIVE to make a new drive the default.
+* This should also be 32 bit or bigger.
+ FCB $86
+ FCC 'OFFSE' ; 'OFFSET'
+ FCB $D4
+ FDB SCR-6
+OFSET FDB DOUSER
+ FDB XOFSET-UORIG
+*
+* ======>> 74 <<
+* ( --- vadr )
+* Current context of interpretation (vocabulary root).
+ FCB $87
+ FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
+ FCB $D4
+ FDB OFSET-9
+CONTXT FDB DOUSER
+ FDB XCONT-UORIG
+*
+* ======>> 75 <<
+* ( --- vadr )
+* Current context of definition (vocabulary root).
+ FCB $87
+ FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
+ FCB $D4
+ FDB CONTXT-10
+CURENT FDB DOUSER
+ FDB XCURR-UORIG
+*
+* ======>> 76 <<
+* ( --- vadr )
+* Compiler/interpreter state.
+ FCB $85
+ FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
+ FCB $C5
+ FDB CURENT-10
+STATE FDB DOUSER
+ FDB XSTATE-UORIG
+*
+* ======>> 77 <<
+* ( --- vadr )
+* Numeric conversion base.
+ FCB $84
+ FCC 'BAS' ; 'BASE' : number base for all input & output
+ FCB $C5
+ FDB STATE-8
+BASE FDB DOUSER
+ FDB XBASE-UORIG
+*
+* ======>> 78 <<
+* ( --- vadr )
+* Decimal point location for output.
+ FCB $83
+ FCC 'DP' ; 'DPL'
+ FCB $CC
+ FDB BASE-7
+DPL FDB DOUSER
+ FDB XDPL-UORIG
+*
+* ======>> 79 <<
+* ( --- vadr )
+* Field width for I/O formatting.
+ FCB $83
+ FCC 'FL' ; 'FLD'
+ FCB $C4
+ FDB DPL-6
+FLD FDB DOUSER
+ FDB XFLD-UORIG
+*
+* ======>> 80 <<
+* ( --- vadr )
+* Compiler stack mark for stack check.
+ FCB $83
+ FCC 'CS' ; 'CSP'
+ FCB $D0
+ FDB FLD-6
+CSP FDB DOUSER
+ FDB XCSP-UORIG
+*
+* ======>> 81 <<
+* ( --- vadr )
+* Editing cursor location.
+ FCB $82
+ FCC 'R' ; 'R#'
+ FCB $A3
+ FDB CSP-6
+RNUM FDB DOUSER
+ FDB XRNUM-UORIG
+*
+* ======>> 82 <<
+* ( --- vadr )
+* Pointer to last HELD character in PAD.
+ FCB $83
+ FCC 'HL' ; 'HLD'
+ FCB $C4
+ FDB RNUM-5
+HLD FDB DOCON
+ FDB XHLD
+*
+* ======>> 82.5 <<== SPECIAL
+* ( --- vadr )
+* Line width of active terminal.
+ FCB $87
+ FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
+ FCB $D3
+ FDB HLD-6
+COLUMS FDB DOUSER
+ FDB XCOLUM-UORIG
+*
+* ######>> screen 38 <<
+**
+** An INCREMENTER probably should not be defined without a defined CONSTANT?
+**
+** Make an INCREMENTER compiling word (not in model):
+** ( n --- )
+** { n INCREMENTER name } typical input
+** CREATE a header and compile the increment constant,
+** then overwrite the header with a call to DOINC.
+* FCB $8B
+* FCC 'INCREMENTE' ; 'INCREMENTER'
+* FCB $D2
+* FDB COLUMS-10
+* INCR FDB DOCOL,CON,PSCODE
+** ( n --- ninc )
+** Characteristic of an INCREMENTER.
+** This is too naive:
+* DOINC LDD ,U
+* ADDD NATWID,X ; Add the increment.
+* STD ,U
+* RTS
+* Compiling word should check that it is compiling a CONSTANT.
+*
+* ======>> 83 <<
+* ( n --- n+1 )
+ FCB $82
+ FCC '1' ; '1+'
+ FCB $AB
+ FDB COLUMS-10
+* Using the model keeps things semantically connected for other processors:
+ONEP FDB DOCOL,ONE,PLUS
+ FDB SEMIS
+** Greedy alternative:
+* ONEP FDB *+NATWID
+* LDD ,U
+* ADDD ONEV,PCR
+* STD ,U
+* RTS
+* Naive alternative:
+* ONEP FDB DOINC
+* FDB 1
+* Naive alternative:
+* ONEP FDB *+NATWID
+* LDD ,U
+* ADDD #1 ; It's hard to imagine 1+ being other than 1.
+* STD ,U
+* RTS
+*
+* ======>> 84 <<
+* ( n --- n+2 )
+ FCB $82
+ FCC '2' ; '2+'
+ FCB $AB
+ FDB ONEP-5
+* Using the model keeps things semantically connected for other processors:
+TWOP FDB DOCOL,TWO,PLUS
+ FDB SEMIS
+** Greedy alternative:
+* TWOP FDB *+NATWID
+* LDD ,U
+* ADDD TWOV,PCR ; See NAT+ (NATP)
+* STD ,U
+* RTS
+* Naive alternative:
+* TWOP FDB DOINC
+* FDB 2
+* Naive alternative:
+* TWOP FDB *+NATWID
+* LDD ,U
+* ADDD #2 ; See NAT+ (NATP)
+* STD ,U
+* RTS
+*
+* ======>> 85 <<
+* ( --- adr )
+* Get the DICTPT allocation, like a USER constant.
+* Should check the stack and heap for collision.
+ FCB $84
+ FCC 'HER' ; 'HERE'
+ FCB $C5
+ FDB TWOP-5
+HERE FDB DOCOL,DICTPT,AT
+ FDB SEMIS
+*
+* ======>> 86 <<
+* ( n --- )
+* Increase/decrease heap (add n to DP),
+* Should ERROR check stack/heap.
+ FCB $85
+ FCC 'ALLO' ; 'ALLOT'
+ FCB $D4
+ FDB HERE-7
+ALLOT FDB DOCOL,DICTPT,PSTORE
+ FDB SEMIS
+*
+* ======>> 87 <<
+* ( n --- )
+* Store word n at DP++,
+* Should ERROR check stack/heap.
+ FCB $81 ; , (COMMA)
+ FCB $AC
+ FDB ALLOT-8
+COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT
+ FDB SEMIS
+* COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
+* FDB SEMIS
+*
+* ======>> 88 <<
+* ( b --- )
+* Store byte b at DP+,
+* Should ERROR check stack/heap.
+ FCB $82
+ FCC 'C' ; 'C,'
+ FCB $AC
+ FDB COMMA-4
+CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
+ FDB SEMIS
+*
+* ======>> 89 <<
+* ( n1 n2 --- n1-n2 )
+* Subtract top two words.
+ FCB $81 ; -
+ FCB $AD
+ FDB CCOMM-5
+SUB FDB *+NATWID
+ LDD NATWID,U ; #2~6
+ SUBD ,U++ ; #2~9
+ STD ,U ; #2~5
+ RTS ; #1~5 = #7~25
+* SUB FDB DOCOL,MINUS,PLUS
+* FDB SEMIS ; Costs 6 bytes and lots of cycles.
+*
+* ======>> 90 <<
+* ( n1 n2 --- n1==n2 )
+* Return flag true if n1 and n2 are equal, otherwise false.
+ FCB $81 =
+ FCB $BD
+ FDB SUB-4
+EQUAL FDB DOCOL,SUB,ZEQU
+ FDB SEMIS
+*
+* ======>> 91 <<
+* ( n1 n2 --- n1<n2 )
+* Return flag true if n1 is less than n2, otherwise false.
+ FCB $81 <
+ FCB $BC
+ FDB EQUAL-4
+LESS FDB *+NATWID
+ LDD NATWID,U
+ SUBD ,U++
+ BGE FALSE
+TRUE LDD #1
+ STD ,U
+ RTS
+FALSE LDD #0
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* CMPA 0,X
+* LEAS 1,S ;
+* BGT LESST
+* BNE LESSF
+* CMPB 1,X ; Why not sub, sbc, bge?
+* BHI LESST
+* LESSF CLRB ;
+* BRA LESSX
+* LESST LDB #1
+* LESSX CLRA ;
+* LEAS 1,S ;
+* JMP PUSHBA
+*
+* ======>> 92 <<
+* ( n1 n2 --- n1>n2 )
+* Return flag true if n1 is greater than n2, false otherwise.
+ FCB $81 >
+ FCB $BE
+ FDB LESS-4
+GREAT FDB DOCOL,SWAP,LESS
+ FDB SEMIS
+*
+* ======>> 93 <<
+* ( n1 n2 n3 --- n2 n3 n1 )
+* Rotate the top three words on stack,
+* bringing the third word to the top.
+ FCB $83
+ FCC 'RO' ; 'ROT'
+ FCB $D4
+ FDB GREAT-4
+ROT FDB *+NATWID
+ PSHS Y
+ PULU D,X,Y
+ PSHU D,X
+ PSHU Y
+ PULS Y,PC
+* ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
+* FDB SEMIS
+*
+* ======>> 94 <<
+* ( --- )
+* EMIT a SPACE.
+ FCB $85
+ FCC 'SPAC' ; 'SPACE'
+ FCB $C5
+ FDB ROT-6
+SPACE FDB DOCOL,BL,EMIT
+ FDB SEMIS
+*
+* ======>> 95 <<
+* ( n0 n1 --- min(n0,n1) )
+* Leave the minimum of the top two integers.
+* Being too greedy here, but, whatever.
+ FCB $83
+ FCC 'MI' ; 'MIN'
+ FCB $CE
+ FDB SPACE-8
+MIN FDB *+NATWID
+ PULU D
+ CMPD ,U
+ BLE MINX
+ STD ,U
+MINX RTS
+* MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
+* FDB MIN2-*-NATWID
+* FDB SWAP
+* MIN2 FDB DROP
+* FDB SEMIS
+*
+* ======>> 96 <<
+* ( n0 n1 --- max(n0,n1) )
+* Leave the maximum of the top two integers.
+* Really should leave this as in the model.
+ FCB $83
+ FCC 'MA' ; 'MAX'
+ FCB $D8
+ FDB MIN-6
+MAX FDB *+NATWID
+ PULU D
+ CMPD ,U
+ BLE MAXX
+ STD ,U
+MAXX RTS
+* MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
+* FDB MAX2-*-NATWID
+* FDB SWAP
+* MAX2 FDB DROP
+* FDB SEMIS
+*
+* ======>> 97 <<
+* ( 0 --- 0 )
+* ( n --- n n )
+* DUP if non-zero.
+ FCB $84
+ FCC '-DU' ; '-DUP'
+ FCB $D0
+ FDB MAX-6
+DDUP FDB *+NATWID
+ LDD ,U
+ BEQ DDUPX
+ PSHU D
+DDUPX RTS
+* DDUP FDB DOCOL,DUP,ZBRAN
+* FDB DDUP2-*-NATWID
+* FDB DUP
+* DDUP2 FDB SEMIS
+*
+* ######>> screen 39 <<
+* ======>> 98.1 <<
+* Supplemental:
+* ( n<0 --- -1 )
+* ( n>=~ --- 1 )
+* Change top integer to its sign.
+ FCB $86
+ FCC 'SIGNU' ; 'SIGNUM'
+ FCB $CD
+ FDB DDUP-7
+SIGNUM FDB *+NATWID
+SIGNUE LDB #1
+ LDA ,U
+ BPL SIGNUP
+ NEGB
+SIGNUP SEX ; Couldn't they have called SignEXtend EXT instead?
+ STD ,U ; Am I too much of a prude?
+ RTS
+* 6800 model version should be something like this:
+* LDB #1
+* CLRA
+* TSX
+* TST ,X
+* BPL SIGNUP
+* NEGB
+* COMA
+* SIGNUP JMP STABX
+*
+* ======>> 98 <<
+* ( adr1 direction --- adr2 )
+* TRAVERSE the symbol name.
+* If direction is 1, find the end.
+* If direction is -1, find the beginning.
+ FCB $88
+ FCC 'TRAVERS' ; 'TRAVERSE'
+ FCB $C5
+ FDB SIGNUM-9
+TRAV FDB *+NATWID
+ BSR SIGNUE ; Convert negative to -, zero or positive to 1.
+ LDD ,U++ ; Still in D, but we have to pop it anyway.
+ LDX ,U ; If D is 1 or -1, so is B.
+ LDA #$7F
+TRAVLP LEAX B,X ; Don't look at the one we start at.
+ CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL.
+ BCC TRAVLP
+TRAVDN STX ,U
+ RTS
+* Doing this in 6809 just because it can be done may be getting too greedy.
+* TRAV FDB DOCOL,SWAP
+* TRAV2 FDB OVER,PLUS,LIT8
+* FCB $7F
+* FDB OVER,CAT,LESS,ZBRAN
+* FDB TRAV2-*-NATWID
+* FDB SWAP,DROP
+* FDB SEMIS
+*
+* ======>> 99 <<
+* ( --- symptr )
+* Fetch CURRENT as a per-USER constant.
+ FCB $86
+ FCC 'LATES' ; 'LATEST'
+ FCB $D4
+ FDB TRAV-11
+LATEST FDB DOCOL,CURENT,AT,AT
+ FDB SEMIS
+* LATEST FDB *+NATWID
+* Getting too greedy:
+* Version 1:
+* TFR DP,A
+* CLRB
+* TFR D,X
+* LDD CURENT+NATWID,PCR
+* LDX [D,X]
+* PSHU X ; Leave the address in X.
+* RTS
+* Version 2:
+* LEAX CURENT,PCR
+* JSR [,X]
+* PULU X
+* LDX [,X]
+* PSHU X
+* RTS
+* Too greedy, too many smantic holes to fall through.
+* If the address at the CFA is made relative,
+* this is part of the code that would be affected
+* if it is in native CPU code.
+*
+* ======>> 100 <<
+* Wanted to do these as INCREMENTERs,
+* but I need to stick with the model as much as possible,
+* (mostly, LOL) adding code only to make the model more clear.
+* ( pfa --- lfa )
+* Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
+ FCB $83
+ FCC 'LF' ; 'LFA'
+ FCB $C1
+ FDB LATEST-9
+LFA FDB DOCOL,LIT8
+* FCB 4
+ FCB 2*NATWID
+ FDB SUB
+ FDB SEMIS
+*
+* ======>> 101 <<
+* ( pfa --- cfa )
+* Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
+ FCB $83
+ FCC 'CF' ; 'CFA'
+ FCB $C1
+ FDB LFA-6
+* CFA FDB DOCOL,TWO,SUB
+CFA FDB DOCOL,NATWC,SUB
+ FDB SEMIS
+*
+* ======>> 102 <<
+* ( pfa --- nfa )
+* Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
+ FCB $83
+ FCC 'NF' ; 'NFA'
+ FCB $C1
+ FDB CFA-6
+NFA FDB DOCOL,LIT8
+* FCB 5
+ FCB NATWID*2+1
+ FDB SUB,ONE,MINUS,TRAV
+ FDB SEMIS
+*
+* ======>> 103 <<
+* ( nfa --- pfa )
+* Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
+ FCB $83
+ FCC 'PF' ; 'PFA'
+ FCB $C1
+ FDB NFA-6
+PFA FDB DOCOL,ONE,TRAV,LIT8
+* FCB 5
+ FCB NATWID*2+1
+ FDB PLUS
+ FDB SEMIS
+*
+* ######>> screen 40 <<
+* ======>> 104 <<
+* ( --- )
+* Save the parameter stack pointer in CSP for compiler checks.
+ FCB $84
+ FCC '!CS' ; '!CSP'
+ FCB $D0
+ FDB PFA-6
+SCSP FDB DOCOL,SPAT,CSP,STORE
+ FDB SEMIS
+*
+* ======>> 105 <<
+* ( 0 n --- ) ( *** )
+* ( true n --- IN BLK ) ( anything *** nothing )
+* If flag is false, do nothing.
+* If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
+* Leaves cursor position (IN)
+* and currently loading block number (BLK) on stack, for analysis.
+*
+* This one is too important to be high-level Forth codes.
+* When we have an error, we want to disturb as little as possible.
+* But fixing that cascades through ERROR and MESSAGE
+* into the disk block system.
+* And we aren't ready for that yet.
+ FCB $86
+ FCC '?ERRO' ; '?ERROR'
+ FCB $D2
+ FDB SCSP-7
+* QERR FDB *+NATWID
+* LDD NATWID,U
+* BNE QERROR
+* LEAU 2*NATWID,U
+* RTS
+** this doesn't work anyway: QERROR LBR ERROR
+QERR FDB DOCOL,SWAP,ZBRAN
+ FDB QERR2-*-NATWID
+ FDB ERROR,BRAN
+ FDB QERR3-*-NATWID
+QERR2 FDB DROP
+QERR3 FDB SEMIS
+*
+* ======>> 106 <<
+* STATE is compiling:
+* ( --- ) ( *** )
+* STATE is compiling:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not compiling.
+ FCB $85
+ FCC '?COM' ; '?COMP'
+ FCB $D0
+ FDB QERR-9
+QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8
+ FCB $11
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 107 <<
+* STATE is executing:
+* ( --- ) ( *** )
+* STATE is executing:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not executing.
+ FCB $85
+ FCC '?EXE' ; '?EXEC'
+ FCB $C3
+ FDB QCOMP-8
+QEXEC FDB DOCOL,STATE,AT,LIT8
+ FCB $12
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 108 <<
+* ( n1 n1 --- ) ( *** )
+* ( n1 n2 --- IN BLK ) ( anything *** nothing )
+* ERROR if top two are unequal.
+* MESSAGE says compiled conditionals do not match.
+ FCB $86
+ FCC '?PAIR' ; '?PAIRS'
+ FCB $D3
+ FDB QEXEC-8
+QPAIRS FDB DOCOL,SUB,LIT8
+ FCB $13
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 109 <<
+* CSP and parameter stack are balanced (equal):
+* ( --- ) ( *** )
+* CSP and parameter stack are not balanced (unequal):
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if return/control stack is not at same level as last !CSP.
+* Usually indicates that a definition has been left incomplete.
+ FCB $84
+ FCC '?CS' ; '?CSP'
+ FCB $D0
+ FDB QPAIRS-9
+QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8
+ FCB $14
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 110 <<
+* Active BLK input:
+* ( --- ) ( *** )
+* No active BLK input:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not loading, i. e., if BLK is zero.
+ FCB $88
+ FCC '?LOADIN' ; '?LOADING'
+ FCB $C7
+ FDB QCSP-7
+QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8
+ FCB $16
+ FDB QERR
+ FDB SEMIS
+*
+* ######>> screen 41 <<
+* ======>> 111 <<
+* ( --- )
+* Compile an in-line literal value from the instruction stream.
+ FCB $87
+ FCC 'COMPIL' ; 'COMPILE'
+ FCB $C5
+ FDB QLOAD-11
+* COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
+* COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
+COMPIL FDB DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
+ FDB SEMIS
+*
+* ======>> 112 <<
+* ( --- ) P
+* Clear the compile state bit(s) (shift to interpret).
+ FCB $C1 [ immediate
+ FCB $DB
+ FDB COMPIL-10
+LBRAK FDB DOCOL,ZERO,STATE,STORE
+ FDB SEMIS
+*
+* ======>> 113 <<
+*
+STCOMP EQU $C0
+* ( --- )
+* Set the compile state bit(s) (shift to compile).
+ FCB $81 ]
+ FCB $DD
+ FDB LBRAK-4
+RBRAK FDB DOCOL,LIT8
+ FCB STCOMP
+ FDB STATE,STORE
+ FDB SEMIS
+*
+* ======>> 114 <<
+* ( --- )
+* Toggle SMUDGE bit of LATEST definition header,
+* to hide it until defined or reveal it after definition.
+ FCB $86
+ FCC 'SMUDG' ; 'SMUDGE'
+ FCB $C5
+ FDB RBRAK-4
+SMUDGE FDB DOCOL,LATEST,LIT8
+ FCB FSMUDG
+ FDB TOGGLE
+ FDB SEMIS
+*
+* ======>> 115 <<
+* ( --- )
+* Set the conversion base to sixteen (b00010000).
+ FCB $83
+ FCC 'HE' ; 'HEX'
+ FCB $D8
+ FDB SMUDGE-9
+HEX FDB DOCOL
+ FDB LIT8
+ FCB 16 ; decimal sixteen
+ FDB BASE,STORE
+ FDB SEMIS
+*
+* ======>> 116 <<
+* ( --- )
+* Set the conversion base to ten (b00001010).
+ FCB $87
+ FCC 'DECIMA' ; 'DECIMAL'
+ FCB $CC
+ FDB HEX-6
+DEC FDB DOCOL
+ FDB LIT8
+ FCB 10 ; decimal ten
+ FDB BASE,STORE
+ FDB SEMIS
+*
+* ######>> screen 42 <<
+* ======>> 117 <<
+* ( --- ) ( IP *** )
+* Pop the saved IP and use it to
+* compile the latest symbol as a reference to a ;CODE definition;
+* overwrite the code field of the symbol found by LATEST
+* with the address of the low-level characteristic code
+* provided in the defining definition.
+* Look closely at where things return, consider the operation of R> and >R .
+*
+* The machine-level code which follows (;CODE) in the instruction stream
+* is not executed by the defining symbol,
+* but becomes the characteristic of the defined symbol.
+* This is the usual way to generate the characteristics of VARIABLEs,
+* CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
+*
+* Finally, note that, if code shifts from low level back to high
+* (native CPU machine code calling into a list of FORTH codes),
+* the low level code can't just call a high-level definition.
+* Leaf definitions can directly call other leaf definitions,
+* but not non-leafs.
+* It will need an anonymous list, probably embedded in the low-level code,
+* and Y and X will have to be set appropriately before entering the list.
+ FCB $87
+ FCC '(;CODE' ; '(;CODE)'
+ FCB $A9
+ FDB DEC-10
+* PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
+PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+ FDB LATEST,PFA,CFA,STORE
+ FDB SEMIS
+*
+* ======>> 118 <<
+* ( --- ) P
+* ?CSP to see if there are loose ends in the defining definition
+* before shifting to the assembler,
+* compile (;CODE) in the defining definition's instruction stream,
+* shift to interpreting,
+* make the ASSEMBLER vocabulary current,
+* and !CSP to mark the stack
+* in preparation for assembling low-level code.
+* Note that ;CODE, unlike DOES>, is IMMEDIATE,
+* and compiles (;CODE),
+* which will do the actual work of changing
+* the LATEST definition's characteristic when the defining word runs.
+* Assembly is done by the interpreter, rather than the compiler.
+* I could have avoided the anomalous three-byte code fields by
+*
+* Note that the ASSEMBLER is not part of the model (at this time).
+* That means that, until the assembler is ready,
+* if you want to define low-level words,
+* you have to poke (comma) in hand-assembled stuff.
+*
+ FCB $C5 immediate
+ FCC ';COD' ; ';CODE'
+ FCB $C5
+ FDB PSCODE-10
+SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
+ FDB SEMIS
+* note: "QSTACK" will be replaced by "ASSEMBLER" later
+*
+* ######>> screen 43 <<
+* ======>> 119 <<
+* ( --- ) C
+* Make the word currently being defined
+* build a header for DOES> definitions.
+* Actually just compiles a CONSTANT zero
+* which can be overwritten later by DOES>.
+* Since the fig models were established, this technique has been deprecated.
+*
+* Note that <BUILDS is not IMMEDIATE,
+* and therefore executes during a definition's run-time,
+* rather than its compile-time.
+* It is not intended to be used directly,
+* but rather so that one definition word can build another.
+* Also, note that nothing particularly special happens
+* in the defining definition until DOES> executes.
+* The name <BUILDS is intended to be a reminder of what is about to occur.
+*
+* <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
+ FCB $87
+ FCC '<BUILD' ; '<BUILDS'
+ FCB $D3
+ FDB SEMIC-8
+BUILDS FDB DOCOL,ZERO,CON
+ FDB SEMIS
+*
+* ======>> 120 <<
+* ( --- ) ( IP *** ) C
+* Define run-time behavior of definitions compiled/defined
+* by a high-level defining definition --
+* the FORTH equivalent of a compiler-compiler.
+* DOES> assumes that the LATEST symbol table entry
+* has at least one word of parameter field,
+* which <BUILDS provides.
+* Note that DOES> is also not IMMEDIATE.
+*
+* When the defining word containing DOES> executes the DOES> icode,
+* it overwrites the LATEST symbol's CFA with jsr <XDOES,
+* overwrites the first word of that symbol's parameter field with its own IP,
+* and pops the previous IP from the return stack.
+* The icodes which follow DOES> in the stream
+* do not execute at the defining word's run-time.
+*
+* Examining XDOES in the virtual machine shows
+* that the defined word will execute those icodes
+* which follow DOES> at its own run-time.
+*
+* The advantage of this kind of behaviour,
+* which you will also note in ;CODE,
+* is that the defined word can contain
+* both operations and data to be operated on.
+* This is how FORTH data objects define their own behavior.
+*
+* Finally, note that the effective parameter field for DOES> definitions
+* starts two NATWID words after the CFA, instead of just one
+* (four bytes instead of two in a sixteen-bit addressing Forth).
+*
+* VOCABULARYs will use this. See definition of word FORTH.
+ FCB $85
+ FCC 'DOES' ; 'DOES>'
+ FCB $BE
+ FDB BUILDS-10
+* DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
+DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+ FDB LATEST,PFA,STORE
+ FDB PSCODE
+*
+* ( --- PFA+NATWID ) ( *** IP )
+* Characteristic of a DOES> defined word.
+* The characteristics of DOES> definitions are written in high-level
+* Forth codes rather than native CPU machine level code.
+* The first parameter word points to the high-level characteristic.
+* This routine's job is to push the IP,
+* load the high level characteristic pointer in IP,
+* and leave the address following the characteristic pointer on the stack
+* so the parameter field can be accessed.
+DODOES LDD ,S ; Keep the return address.
+ STY ,S ; Save/nest the current IP on the return stack.
+ LDY NATWID,X ; First parameter is new IP.
+ LEAX 2*NATWID,X ; Address of second parameter.
+ PSHU X
+ TFR D,PC ; Synthetic return.
+*
+* From the 6800 model:
+* DODOES LDA IP
+* LDB IP+1
+* LDX RP make room on return stack
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* STA 2,X push return address
+* STB 3,X
+* LDX W get addr of pointer to run-time code
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX N stash it in scratch area
+* LDX 0,X get new IP
+* STX IP
+* CLRA ; get address of parameter
+* LDB #2
+* ADDB N+1
+* ADCA N
+* PSHS B ; and push it on data stack
+* PSHS A ;
+* JMP NEXT2
+*
+* ######>> screen 44 <<
+* ======>> 121 <<
+* ( strptr --- strptr+1 count )
+* Convert counted string to string and count.
+* (Fetch the byte at strptr, post-increment.)
+ FCB $85
+ FCC 'COUN' ; 'COUNT'
+ FCB $D4
+ FDB DOES-8
+COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
+ FDB SEMIS
+*
+* ======>> 122 <<
+* ( strptr count --- )
+* EMIT count characters at strptr.
+ FCB $84
+ FCC 'TYP' ; 'TYPE'
+ FCB $C5
+ FDB COUNT-8
+TYPE FDB DOCOL,DDUP,ZBRAN
+ FDB TYPE3-*-NATWID
+ FDB OVER,PLUS,SWAP,XDO
+TYPE2 FDB I,CAT,EMIT,XLOOP
+ FDB TYPE2-*-NATWID
+ FDB BRAN
+ FDB TYPE4-*-NATWID
+TYPE3 FDB DROP
+TYPE4 FDB SEMIS
+*
+* ======>> 123 <<
+* ( strptr count1 --- strptr count2 )
+* Supress trailing blanks (subtract count of trailing blanks from strptr).
+ FCB $89
+ FCC '-TRAILIN' ; '-TRAILING'
+ FCB $C7
+ FDB TYPE-7
+DTRAIL FDB DOCOL,DUP,ZERO,XDO
+DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
+ FDB SUB,ZBRAN
+ FDB DTRAL3-*-NATWID
+ FDB LEAVE,BRAN
+ FDB DTRAL4-*-NATWID
+DTRAL3 FDB ONE,SUB
+DTRAL4 FDB XLOOP
+ FDB DTRAL2-*-NATWID
+ FDB SEMIS
+*
+* ======>> 124 <<
+* ( --- )
+* TYPE counted string out of instruction stream (updating IP).
+ FCB $84
+ FCC '(."' ; '(.")'
+ FCB $A9
+ FDB DTRAIL-12
+* PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
+* PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
+PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP
+ FDB FROMR,PLUS,TOR,TYPE
+ FDB SEMIS
+*
+* ======>> 125 <<
+* ( --- ) P
+* { ." something-to-be-printed " } typical input
+* Use WORD to parse to trailing quote;
+* if compiling, compile XDOTQ and string parsed,
+* otherwise, TYPE string.
+ FCB $C2 immediate
+ FCC '.' ; '."'
+ FCB $A2
+ FDB PDOTQ-7
+DOTQ FDB DOCOL
+ FDB LIT8
+ FCB $22 ascii quote
+ FDB STATE,AT,ZBRAN
+ FDB DOTQ1-*-NATWID
+ FDB COMPIL,PDOTQ,WORD
+ FDB HERE,CAT,ONEP,ALLOT,BRAN
+ FDB DOTQ2-*-NATWID
+DOTQ1 FDB WORD,HERE,COUNT,TYPE
+DOTQ2 FDB SEMIS
+*
+* ######>> screen 45 <<
+* ======>> 126 <<== MACHINE DEPENDENT
+* ( --- ) ( *** )
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if parameter stack out of bounds.
+*
+* But checking whether the stack is in bounds or not
+* really should not use the stack.
+* And there really should be a ?RSTACK, as well.
+ FCB $86
+ FCC '?STAC' ; '?STACK'
+ FCB $CB
+ FDB DOTQ-5
+QSTACK FDB DOCOL,LIT8
+* FCB $12
+ FCB SINIT-ORIG
+* But why use that instead of XSPZER (S0)?
+* Multi-user or multi-tasking would not want that.
+* CMPU <XSPZER
+* FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
+ FDB PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
+ FDB QERR
+* prints 'empty stack'
+*
+QSTAC2 FDB SPAT
+* Here, we compare with a value at least 128
+* higher than dict. ptr. (DICTPT)
+ FDB HERE,LIT8
+ FCB $80 ; This is a rough check anyway, leave it as is.
+ FDB PLUS,LESS,ZBRAN
+ FDB QSTAC3-*-NATWID
+ FDB TWO ; NOT the NATWID constant!
+ FDB QERR
+* prints 'full stack'
+*
+QSTAC3 FDB SEMIS
+*
+* ======>> 127 << this word's function
+* is done by ?STACK in this version
+* FCB $85
+* FCC 4,?FREE
+* FCB $C5
+* FDB QSTACK-9
+*QFREE FDB DOCOL,SPAT,HERE,LIT8
+* FCB $80
+* FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
+*
+* ######>> screen 46 <<
+* ======>> 128 <<
+* ( buffer n --- )
+* ***** Check that this is how it works here:
+* Get up to n-1 characters from the keyboard,
+* storing at buffer and echoing, with backspace editing,
+* quitting when a CR is read.
+* Terminate it with a NUL.
+ FCB $86
+ FCC 'EXPEC' ; 'EXPECT'
+ FCB $D4
+ FDB QSTACK-9
+EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
+* EXPEC2 FDB KEY,DUP,LIT8
+EXPEC2 FDB KEY
+* FDB LIT,$1C,SHOTOS ; DBG
+ FDB DUP,LIT8
+ FCB BACKSP-ORIG
+ FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing
+ FDB EXPEC3-*-NATWID
+ FDB DROP,LIT8
+ FCB 8 ( backspace character to emit )
+ FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
+ FDB TOR,SUB,BRAN
+ FDB EXPEC6-*-NATWID
+EXPEC3 FDB DUP,LIT8
+ FCB $D ( carriage return )
+ FDB EQUAL,ZBRAN
+ FDB EXPEC4-*-NATWID
+ FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
+ FDB EXPEC5-*-NATWID
+EXPEC4 FDB DUP
+EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
+EXPEC6 FDB EMIT,XLOOP
+ FDB EXPEC2-*-NATWID
+ FDB DROP
+ FDB SEMIS
+*
+* ======>> 129 <<
+* ( --- )
+* EXPECT 128 (TWID) characters to TIB.
+ FCB $85
+ FCC 'QUER' ; 'QUERY'
+ FCB $D9
+ FDB EXPECT-9
+QUERY FDB DOCOL,TIB,AT,COLUMS
+ FDB AT,EXPECT,ZERO,IN,STORE
+ FDB SEMIS
+*
+* ======>> 130 <<
+* ( --- ) P
+* End interpretation of a line or screen, and/or prepare for a new block.
+* Note that the name of this definition is an empty string,
+* so it matches on the terminating NUL in the terminal or block buffer.
+ FCB $C1 immediate < carriage return >
+ FCB $80
+ FDB QUERY-8
+NULL FDB DOCOL,BLK,AT,ZBRAN
+ FDB NULL2-*-NATWID
+ FDB ONE,BLK,PSTORE
+ FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
+ FDB ZEQU
+* check for end of screen
+ FDB ZBRAN
+ FDB NULL1-*-NATWID
+ FDB QEXEC,FROMR,DROP
+NULL1 FDB BRAN
+ FDB NULL3-*-NATWID
+NULL2 FDB FROMR,DROP
+NULL3 FDB SEMIS
+*
+* ######>> screen 47 <<
+* ======>> 133 <<
+* ( adr n b --- )
+* Fill n bytes at adr with b.
+* This relies on CMOVE having a certain lack of parameter checking,
+* where overlapping regions are not properly inverted in copy.
+* And this really should be done in low-level.
+* None of the advantages of doing things in high-level apply to fill.
+ FCB $84
+ FCC 'FIL' ; 'FILL'
+ FCB $CC
+ FDB NULL-4
+FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
+ FDB FROMR,ONE,SUB,CMOVE
+ FDB SEMIS
+*
+* ======>> 134 <<
+* ( adr n --- )
+* Fill n bytes with 0.
+ FCB $85
+ FCC 'ERAS' ; 'ERASE'
+ FCB $C5
+ FDB FILL-7
+ERASE FDB DOCOL,ZERO,FILL
+ FDB SEMIS
+*
+* ======>> 135 <<
+* ( adr n --- )
+* Fill n bytes with ASCII SPACE.
+ FCB $86
+ FCC 'BLANK' ; 'BLANKS'
+ FCB $D3
+ FDB ERASE-8
+BLANKS FDB DOCOL,BL,FILL
+ FDB SEMIS
+*
+* ======>> 136 <<
+* ( c --- )
+* Format a character at the left of the HLD output buffer.
+ FCB $84
+ FCC 'HOL' ; 'HOLD'
+ FCB $C4
+ FDB BLANKS-9
+HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
+ FDB SEMIS
+*
+* ======>> 137 <<
+* ( --- adr )
+* Give the address of the output PAD buffer.
+* PAD points to the end of a 68 byte buffer for numeric conversion.
+ FCB $83
+ FCC 'PA' ; 'PAD'
+ FCB $C4
+ FDB HOLD-7
+PAD FDB DOCOL,HERE,LIT8
+ FCB $44
+ FDB PLUS
+ FDB SEMIS
+*
+* ######>> screen 48 <<
+* ======>> 138 <<
+* ( c --- )
+* Scan a string terminated by the character c or ASCII NUL out of input;
+* store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
+* Leading c are passed over, per ENCLOSE.
+* Scans from BLK, or from TIB if BLK is zero.
+* May overwrite the numeric conversion pad,
+* if really long (length > 31) symbols are scanned.
+ FCB $84
+ FCC 'WOR' ; 'WORD'
+ FCB $C4
+ FDB PAD-6
+WORD FDB DOCOL,BLK,AT,ZBRAN
+ FDB WORD2-*-NATWID
+ FDB BLK,AT,BLOCK,BRAN
+ FDB WORD3-*-NATWID
+WORD2 FDB TIB,AT
+WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
+ FCB 34
+ FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
+ FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
+ FDB SEMIS
+*
+* ######>> screen 49 <<
+* ======>> 139 <<
+* ( d1 string --- d2 adr )
+* Convert the text at string into a number, accumulating the result into d1,
+* leaving adr pointing to the first character not converted.
+* If DPL is non-negative at entry,
+* accumulates the number of characters converted into DPL.
+ FCB $88
+ FCC '(NUMBER' ; '(NUMBER)'
+ FCB $A9
+ FDB WORD-7
+PNUMB FDB DOCOL
+PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
+ FDB PNUMB4-*-NATWID
+ FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
+ FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
+ FDB PNUMB3-*-NATWID
+ FDB ONE,DPL,PSTORE
+PNUMB3 FDB FROMR,BRAN
+ FDB PNUMB2-*-NATWID
+PNUMB4 FDB FROMR
+ FDB SEMIS
+*
+* ======>> 140 <<
+* ( ctstr --- d )
+* Convert text at ctstr to a double integer,
+* taking the 0 ERROR if the conversion is not valid.
+* If a decimal point is present,
+* accumulate the count of digits to the decimal point's right into DPL
+* (negative DPL at exit indicates single precision).
+* ctstr is a counted string
+* -- the first byte at ctstr is the length of the string,
+* but NUMBER ignores the count and expects a NUL terminator instead.
+ FCB $86
+ FCC 'NUMBE' ; 'NUMBER'
+ FCB $D2
+ FDB PNUMB-11
+NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
+ FCC "-" minus sign
+ FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
+NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
+ FDB ZBRAN
+ FDB NUMB2-*-NATWID
+ FDB DUP,CAT,LIT8
+ FCC "."
+ FDB SUB,ZERO,QERR,ZERO,BRAN
+ FDB NUMB1-*-NATWID
+NUMB2 FDB DROP,FROMR,ZBRAN
+ FDB NUMB3-*-NATWID
+ FDB DMINUS
+NUMB3 FDB SEMIS
+*
+* ======>> 141 <<
+* ( --- locptr length true ) { -FIND name } typical input
+* ( --- false )
+* Parse a word, then FIND,
+* first in the definition vocabulary,
+* then in the CONTEXT (interpretation) vocabulary, if necessary.
+* Returns what (FIND) returns, flag and optional location and length.
+ FCB $85
+ FCC '-FIN' ; '-FIND'
+ FCB $C4
+ FDB NUMB-9
+DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
+ FDB PFIND,DUP,ZEQU,ZBRAN
+ FDB DFIND2-*-NATWID
+ FDB DROP,HERE,LATEST,PFIND
+DFIND2 FDB SEMIS
+*
+* ######>> screen 50 <<
+* ======>> 142 <<
+* ( anything --- nothing ) ( anything *** nothing )
+* An indirection for ABORT, for ERROR,
+* which may be modified carefully.
+ FCB $87
+ FCC '(ABORT' ; '(ABORT)'
+ FCB $A9
+ FDB DFIND-8
+PABORT FDB DOCOL,ABORT
+ FDB SEMIS
+*
+* ======>> 143 <<
+ FCB $85
+ FCC 'ERRO' ; 'ERROR'
+ FCB $D2
+ FDB PABORT-10
+* This really should not be high level, according to best practices.
+* But fixing that cascades through MESSAGE,
+* requiring re-architecting the disk block system.
+* First, we need to get this transliteration running.
+ERROR FDB DOCOL,WARN,AT,ZLESS
+ FDB ZBRAN
+ FDB ERROR2-*-NATWID
+* note: WARNING is
+* -1 to abort,
+* 0 to print error #
+* and 1 to print error message from disc
+ FDB PABORT
+ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
+ FCB 4,7 ( bell )
+ FCC " ? "
+ FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
+ FDB SEMIS
+*
+* ======>> 144 <<
+* ( n adr --- )
+* Mask byte at adr with n.
+* Not in FIG, don't need it for 8 bit characters after all.
+* FCB $85
+* FCC 'CMAS' ; 'CMASK'
+* FCB $CB ; 'K'
+* FDB ERROR-8
+* CMASK FDB *+NATWID
+* LDX ,U++ ; adr
+* LDD ,U++ ; mask
+* ANDB ,X
+* STB ,X
+* RTS
+*
+* ( adr --- adr )
+* Mask high bit of tail of name in PAD buffer.
+* Not in FIG, need it for 8 bit characters.
+ FCB $86
+ FCC 'IDFLA' ; 'IDFLAT'
+ FCB $D4 ; 'T'
+ FDB ERROR-8
+IDFLAT FDB *+NATWID
+ LDX ,U
+ LDB ,X ; get the count
+ ANDB #CTMASK
+ LDA B,X ; point to the tail
+ ANDA #$7F ; Clear the EndOfName flag bit.
+ STA B,X
+ RTS
+*
+* ( symptr --- )
+* Print definition's name from its NFA.
+ FCB $83
+ FCC 'ID' ; 'ID.'
+ FCB $AE
+ FDB IDFLAT-9
+IDDOT FDB DOCOL,PAD,LIT8
+ FCB 32
+ FDB LIT8
+ FCB $5F ( underline )
+ FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
+* FDB SWAP,CMOVE,PAD,COUNT,LIT8
+ FDB SWAP,CMOVE,PAD
+ FDB IDFLAT
+ FDB COUNT,LIT8
+ FCB 31
+ FDB AND,TYPE,SPACE
+ FDB SEMIS
+*
+* ######>> screen 51 <<
+* ======>> 145 <<
+* ( --- ) { CREATE name } input
+* Parse a name (length < 32 characters) and create a header,
+* reporting first duplicate found in either the defining vocabulary
+* or the context (interpreting) vocabulary.
+* Install the header in the defining vocabulary
+* with CFA dangerously pointing to the parameter field.
+* Leave the name SMUDGEd.
+ FCB $86
+ FCC 'CREAT' ; 'CREATE'
+ FCB $C5
+ FDB IDDOT-6
+CREATE FDB DOCOL,DFIND,ZBRAN
+ FDB CREAT2-*-NATWID
+ FDB DROP,PDOTQ
+ FCB 8
+ FCB 7 ( bel )
+ FCC "redef: "
+ FDB NFA,IDDOT,LIT8
+ FCB 4
+ FDB MESS,SPACE
+CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
+ FDB ONEP,ALLOT,DUP,LIT8
+ FCB ($80|FSMUDG) ; Bracket the name.
+ FDB TOGGLE,HERE,ONE,SUB,LIT8
+ FCB $80
+ FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
+* FDB HERE,TWOP,COMMA
+ FDB HERE,NATP,COMMA
+ FDB SEMIS
+*
+* ######>> screen 52 <<
+* ======>> 146 <<
+* ( --- ) P
+* { [COMPILE] name } typical use
+* -DFIND next WORD and COMPILE it, literally;
+* used to compile immediate definitions into words.
+ FCB $C9 immediate
+ FCC '[COMPILE' ; '[COMPILE]'
+ FCB $DD
+ FDB CREATE-9
+BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
+ FDB SEMIS
+*
+* ======>> 147 <<
+* ( n --- ) if compiling. P
+* ( n --- n ) if interpreting.
+* Compile n as a literal, if compiling.
+ FCB $C7 immediate
+ FCC 'LITERA' ; 'LITERAL'
+ FCB $CC
+ FDB BCOMP-12
+LITER FDB DOCOL,STATE,AT,ZBRAN
+ FDB LITER2-*-NATWID
+ FDB COMPIL,LIT,COMMA
+LITER2 FDB SEMIS
+*
+* ======>> 148 <<
+* ( d --- ) if compiling. P
+* ( d --- d ) if interpreting.
+* Compile d as a double literal, if compiling.
+ FCB $C8 immediate
+ FCC 'DLITERA' ; 'DLITERAL'
+ FCB $CC
+ FDB LITER-10
+DLITER FDB DOCOL,STATE,AT,ZBRAN
+ FDB DLITE2-*-NATWID
+ FDB SWAP,LITER,LITER ; Just two literals in the right order.
+DLITE2 FDB SEMIS
+*
+* ######>> screen 53 <<
+* ======>> 149 <<
+* ( --- )
+* Interpret or compile, according to STATE.
+* Searches words parsed in dictionary first, via -FIND,
+* then checks for valid NUMBER.
+* Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
+* ERROR checks the stack via ?STACK before returning to its caller.
+ FCB $89
+ FCC 'INTERPRE' ; 'INTERPRET'
+ FCB $D4
+ FDB DLITER-11
+INTERP FDB DOCOL
+INTER2 FDB DFIND,ZBRAN
+ FDB INTER5-*-NATWID
+ FDB STATE,AT,LESS
+ FDB ZBRAN
+ FDB INTER3-*-NATWID
+ FDB CFA,COMMA,BRAN
+ FDB INTER4-*-NATWID
+INTER3 FDB CFA,EXEC
+INTER4 FDB BRAN
+ FDB INTER7-*-NATWID
+INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
+ FDB INTER6-*-NATWID
+ FDB DLITER,BRAN
+ FDB INTER7-*-NATWID
+INTER6 FDB DROP,LITER
+INTER7 FDB QSTACK,BRAN
+ FDB INTER2-*-NATWID
+* FDB SEMIS never executed
+
+*
+* ######>> screen 54 <<
+* ======>> 150 <<
+* ( --- )
+* Toggle precedence bit of LATEST definition header.
+* During compiling, most symbols scanned are compiled.
+* IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
+* but may be compiled via ' (TICK).
+ FCB $89
+ FCC 'IMMEDIAT' ; 'IMMEDIATE'
+ FCB $C5
+ FDB INTERP-12
+IMMED FDB DOCOL,LATEST,LIT8
+ FCB FIMMED
+ FDB TOGGLE
+ FDB SEMIS
+*
+* ======>> 151 <<
+* ( --- ) { VOCABULARY name } input
+* Create a vocabulary entry with a flag for terminating vocabulary searches.
+* Store the current search context in it for linking.
+* At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
+ FCB $8A
+ FCC 'VOCABULAR' ; 'VOCABULARY'
+ FCB $D9
+ FDB IMMED-12
+VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
+ FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
+* DOVOC FDB TWOP,CONTXT,STORE
+DOVOC FDB NATP,CONTXT,STORE
+ FDB SEMIS
+*
+* ======>> 152 <<
+*
+* Note: FORTH does not go here in the rom-able dictionary,
+* since FORTH is a type of variable.
+*
+* (Should make a proper architecture for this at some point.)
+*
+*
+* ======>> 153 <<
+* ( --- )
+* Makes the current interpretation CONTEXT vocabulary
+* also the CURRENT defining vocabulary.
+ FCB $8B
+ FCC 'DEFINITION' ; 'DEFINITIONS'
+ FCB $D3
+ FDB VOCAB-13
+DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
+ FDB SEMIS
+*
+* ======>> 154 <<
+* ( --- )
+* Parse out a comment and toss it away.
+* Leaves the first 32 characters in WORDPAD, which may or may not be useful.
+ FCB $C1 immediate (
+ FCB $A8
+ FDB DEFIN-14
+PAREN FDB DOCOL,LIT8
+ FCC ")"
+ FDB WORD
+ FDB SEMIS
+*
+* ######>> screen 55 <<
+* ======>> 155 <<
+* ( anything *** nothing )
+* Clear return stack.
+* Then INTERPRET and, if not compiling, prompt with OK,
+* in infinite loop.
+ FCB $84
+ FCC 'QUI' ; 'QUIT'
+ FCB $D4
+ FDB PAREN-4
+QUIT FDB DOCOL,ZERO,BLK,STORE
+ FDB LBRAK
+*
+* Here is the outer interpretter
+* which gets a line of input, does it, prints " OK"
+* then repeats :
+QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
+ FDB ZBRAN
+ FDB QUIT3-*-NATWID
+ FDB PDOTQ
+ FCB 3
+ FCC ' OK' ; ' OK'
+QUIT3 FDB BRAN
+ FDB QUIT2-*-NATWID
+* FDB SEMIS ( never executed )
+*
+* ======>> 156 <<
+* ( anything --- nothing ) ( anything *** nothing )
+* Clear parameter stack,
+* set STATE to interpret and BASE to DECIMAL,
+* return to input from terminal,
+* restore DRIVE OFFSET to 0,
+* print out "Forth-68",
+* set interpret and define vocabularies to FORTH,
+* and finally, QUIT.
+* Used to force the system to a known state
+* and return control to the initial INTERPRETer.
+ FCB $85
+ FCC 'ABOR' ; 'ABORT'
+ FCB $D4
+ FDB QUIT-7
+ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
+ FCB 10
+ FCC "Forth-6809"
+ FDB FORTH,DEFIN
+ FDB QUIT
+* FDB SEMIS never executed
+ PAGE
+*
+* ######>> screen 56 <<
+* bootstrap code... moves rom contents to ram :
+* ======>> 157 <<
+ FCB $84
+ FCC 'COL' ; 'COLD'
+ FCB $C4
+ FDB ABORT-8
+COLD FDB *+NATWID
+* Ultimately, we want position indepence,
+* so I'm using PCR where it seems reasonable.
+CENT LDS SINIT,PCR ; Get a useable return stack, at least.
+ LDA #IUPDP ; This is not relative to PC.
+ TFR A,DP ; And a useable direct page, too.
+ SETDP IUPDP ; (For good measure.)
+*
+* We'll keep this here for the time being.
+* There are better ways to do this, of course.
+* Re-architect, re-architect.
+ LEAX ERAM,PCR ; end of stuff to move
+ STX <XFENCE ; Borrow this variable for a loop terminator.
+ LDY #RBEG ; bottom of open-ended destination
+ LEAX RAM,PCR ; bottom of stuff to move
+COLD2 LDA ,X+
+ STA ,Y+ ; move TASK & FORTH to ram
+ CMPX <XFENCE
+ BNE COLD2
+* Leaves USE and PREV uninitialized.
+ LDX BUFINT,PCR
+ STX <XUSE
+ STX <XPREV
+* LEAX RAM,PCR
+* STX <XFENCE ; Borrow this variable for a loop terminator.
+* LEAY REND,PCR ; top of destination (included XUSE and XPREV)
+* LEAX ERAM,PCR ; top of stuff to move (included initializers for XUSE and XPREV)
+* COLD2 LDA ,-X
+* STA ,-Y ; move TASK & FORTH to ram
+* CMPX <XFENCE
+* BNE COLD2
+*
+* CENT LDS #REND-1 top of destination
+* LDX #ERAM top of stuff to move
+* COLD2 LEAX -1,X ;
+* LDA 0,X
+* PSHS A ; move TASK & FORTH to ram
+* CMPX #RAM
+* BNE COLD2
+*
+* LDS #XFENCE-1 put stack at a safe place for now
+* But that is taken care of.
+* LDX COLINT
+* STX XCOLUM
+ LDX COLINT,PCR
+ STX <XCOLUM
+* LDX DELINT
+* STX XDELAY
+ LDX DELINT,PCR
+ STX <XDELAY
+* LDX VOCINT
+* STX XVOCL
+ LDX VOCINT,PCR
+ STX <XVOCL
+* LDX DPINIT
+* STX XDICTP
+ LDX DPINIT,PCR
+ STX <XDICTP
+* LDX FENCIN
+* STX XFENCE
+ LDX FENCIN,PCR
+ STX <XFENCE
+*
+WENT LDS SINIT,PCR ; Get a useable return stack, at least.
+ LDA #IUPDP ; This is not relative to PC.
+ TFR A,DP ; And a useable direct page, too.
+ SETDP IUPDP ; (For good measure.)
+*
+ LEAX SINIT,PCR
+ PSHS X ; for loop termination
+ CLRB ; Yes, I'm being a little ridiculous. Only a little.
+ TFR D,Y
+ LEAY XFENCE-UORIG,Y ; top of destination
+ LEAX FENCIN,PCR ; top of stuff to move
+WARM2 LDD ,--X ; All entries are 16 bit.
+ STD ,--Y
+ CMPX ,S
+ BNE WARM2
+ LEAS 2,S ; But we'll reset the return stack shortly, anyway.
+ LDU <XSPZER ; So we can clear the hole above the TOS
+* WENT LDS #XFENCE-1 top of destination
+* LDX #FENCIN top of stuff to move
+* WARM2 LEAX -1,X ;
+* LDA 0,X
+* PSHS A ;
+* CMPX #SINIT
+* BNE WARM2
+*
+* LDS SINIT
+* S is already there.
+* LDX UPINIT
+* STX UP init user ram pointer
+* UP is already there (DP).
+* LDX #ABORT
+* STX IP
+ LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
+*
+ NOP Here is a place to jump to special user
+ NOP initializations such as I/0 interrups
+ NOP
+*
+* For systems with TRACE:
+ LDX #00
+ STX ,U The hole above the parameter stack
+* STX TRLIM clear trace mode
+ STX <TRLIM clear trace mode (both bytes)
+ LDX #0
+* STX BRKPT clear breakpoint address
+ STX <BRKPT clear breakpoint address
+* JMP RPSTOR+2 start the virtual machine running !
+ LBSR RPSTOR+NATWID start the virtual machine running !
+ LEAX WENT,PCR ; But we must also give RP! someplace to return.
+ STX ,S ; This rail might get walked on by (DO).
+ LBRA NEXT
+* RP! sets up the return stack pointer, then Y references abort.
+*
+* Here is the stuff that gets copied to ram :
+* (not * at address $140:)
+* at an appropriate address:
+*
+* RAM FDB $3000,$3000,0,0
+* RAM FDB BUFBAS,BUFBAS,0,0 ; ... except the direct page has moved.
+* These initialization values for USE and PREV were here to help pack the code.
+* They don't belong here unless we move the USER table
+* back below the writable dictionary,
+* *and* move these USER variables to the end of the direct page --
+* *or* let these definitions exist in the USER table.
+RAM EQU *
+
+* ======>> (152) <<
+* ( --- ) P
+* Makes FORTH the current interpretation vocabulary.
+* In order to make this ROMmable, this entry is set up as the tail-end,
+* and copied to RAM in the start-up code.
+* We want a more elegant solution to this, too. Greedy, maybe.
+ FCB $C5 immediate
+ FCC 'FORT' ; 'FORTH'
+ FCB $C8
+ FDB NOOP-7 ; Note that this does not link to COLD!
+RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
+ FDB 0
+ FCC "Copyright 1979 Forth Interest Group, David Lion,"
+ FCB $0D
+ FCC "Parts Copyright 2019 Joel Matthew Rees"
+ FCB $0D
+ FCB $84
+ FCC 'TAS' ; 'TASK'
+ FCB $CB
+ FDB FORTH-8
+RTASK FDB DOCOL,SEMIS
+ERAM EQU *
+ERAMSZ EQU *-RAM ; So we can get a look at it.
+ PAGE
+*
+* ######>> screen 57 <<
+* ======>> 158 <<
+* ( n0 --- d0 )
+* Sign extend n0 to a double integer.
+ FCB $84
+ FCC 'S->' ; 'S->D'
+ FCB $C4
+ FDB COLD-7 ; Note that this does not link to FORTH (RFORTH)!
+STOD FDB DOCOL,DUP,ZLESS,MINUS
+ FDB SEMIS
+
+
+*
+* ======>> 159 <<
+* ( multiplier multiplicand --- product )
+* Signed word multiply.
+ FCB $81 ; *
+ FCB $AA
+ FDB STOD-7
+STAR FDB *+NATWID
+ LBSR USTAR+NATWID ; or [USTAR,PCR]?
+ LEAU NATWID,U ; Drop high word.
+ RTS
+* JSR USTARS
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP NEXT
+*
+* ======>> 160 <<
+* ( dividend divisor --- remainder quotient )
+* M/ in word-only form, i. e., signed division of 2nd word by top word,
+* yielding signed word quotient and remainder.
+* Except *BUG* it isn't signed.
+ FCB $84
+ FCC '/MO' ; '/MOD'
+ FCB $C4
+ FDB STAR-4
+SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
+ FDB SEMIS
+*
+* ======>> 161 <<
+* ( dividend divisor --- quotient )
+* Signed word divide without remainder.
+* Except *BUG* it isn't signed.
+ FCB $81 ; /
+ FCB $AF
+ FDB SLMOD-7
+SLASH FDB DOCOL,SLMOD,SWAP,DROP
+ FDB SEMIS
+*
+* ======>> 162 <<
+* ( dividend divisor --- remainder )
+* Remainder function, result takes sign of dividend.
+ FCB $83
+ FCC 'MO' ; 'MOD'
+ FCB $C4
+ FDB SLASH-4
+MOD FDB DOCOL,SLMOD,DROP
+ FDB SEMIS
+*
+* ======>> 163 <<
+* ( multiplier multiplicand divisor --- remainder quotient )
+* Signed precise division of product:
+* multiply 2nd and 3rd words on stack
+* and divide the 31-bit product by the top word,
+* leaving both quotient and remainder.
+* Remainder takes sign of product.
+* Guaranteed not to lose significant bits in 16 bit integer math.
+ FCB $85
+ FCC '*/MO' ; '*/MOD'
+ FCB $C4
+ FDB MOD-6
+SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
+ FDB SEMIS
+*
+* ======>> 164 <<
+* ( multiplier multiplicand divisor --- quotient )
+* */MOD without remainder.
+ FCB $82
+ FCC '*' ; '*/'
+ FCB $AF
+ FDB SSMOD-8
+SSLASH FDB DOCOL,SSMOD,SWAP,DROP
+ FDB SEMIS
+*
+* ======>> 165 <<
+* ( ud1 u1 --- u2 ud2 )
+* U/ with an (unsigned) double quotient.
+* Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
+* if you are prepared to deal with the extra 16 bits of result.
+ FCB $85
+ FCC 'M/MO' ; 'M/MOD'
+ FCB $C4
+ FDB SSLASH-5
+MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
+ FDB FROMR,SWAP,TOR,USLASH,FROMR
+ FDB SEMIS
+*
+* ======>> 166 <<
+* ( n>=0 --- n )
+* ( n<0 --- -n )
+* Convert the top of stack to its absolute value.
+ FCB $83
+ FCC 'AB' ; 'ABS'
+ FCB $D3
+ FDB MSMOD-8
+ABS FDB DOCOL,DUP,ZLESS,ZBRAN
+ FDB ABS2-*-NATWID
+ FDB MINUS
+ABS2 FDB SEMIS
+*
+* ======>> 167 <<
+* ( d>=0 --- d )
+* ( d<0 --- -d )
+* Convert the top double to its absolute value.
+ FCB $84
+ FCC 'DAB' ; 'DABS'
+ FCB $D3
+ FDB ABS-6
+DABS FDB DOCOL,DUP,ZLESS,ZBRAN
+ FDB DABS2-*-NATWID
+ FDB DMINUS
+DABS2 FDB SEMIS
+*
+* ######>> screen 58 <<
+* Disc primitives :
+* ======>> 168 <<
+* ( --- vadr )
+* Least Recently Used buffer.
+* Really should be with FIRST and LIMIT in the per-task table.
+ FCB $83
+ FCC 'US' ; 'USE'
+ FCB $C5
+ FDB DABS-7
+USE FDB DOCON
+ FDB XUSE
+* ======>> 169 <<
+* ( --- vadr )
+* Most Recently Used buffer.
+* Really should be with FIRST and LIMIT in the per-task table.
+ FCB $84
+ FCC 'PRE' ; 'PREV'
+ FCB $D6
+ FDB USE-6
+PREV FDB DOCON
+ FDB XPREV
+* ======>> 170 <<
+* ( buffer1 --- buffer2 f )
+* Bump to next buffer,
+* flag false if result is PREVious buffer,
+* otherwise flag true.
+* Used in the LRU allocation routines.
+ FCB $84
+ FCC '+BU' ; '+BUF'
+ FCB $C6
+ FDB PREV-7
+* PBUF FDB DOCOL,LIT8
+* FCB $84 ; This was a hard-wiring bug.
+PBUF FDB DOCOL,BBUF,BCTL,PLUS ; Size of the buffer record.
+* FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
+ FDB PLUS,DUP,LIMIT,LESS,ZEQU,OVER,FIRST,LESS,OR,ZBRAN
+ FDB PBUF2-*-NATWID ; Use defensive programming.
+ FDB DROP,FIRST
+PBUF2 FDB DUP,PREV,AT,SUB
+ FDB SEMIS
+*
+* ======>> 171 <<
+* ( --- f )
+* Flag to mark a buffer dirty, in need of being written out.
+* This flag limits the max number of sectors in a disk to ((256^NATWID)/2)-1.
+* It also hard-codes an implicit test which is used elsewhere.
+ FCB $8A
+ FCC 'UPDATE-BI' ; 'UPDATE-BIT'
+ FCB $D4
+ FDB PBUF-7
+UPDBIT FDB DOCON
+ FDB $8000
+*
+* ( --- )
+* Mark PREVious buffer dirty, in need of being written out.
+ FCB $86
+ FCC 'UPDAT' ; 'UPDATE'
+ FCB $C5
+ FDB UPDBIT-13
+* UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
+UPDATE FDB DOCOL,PREV,AT,AT,UPDBIT,OR,PREV,AT,STORE
+ FDB SEMIS
+*
+* ======>> 172 <<
+* ( adr --- )
+* Mark the buffer addressed as empty.
+* Have to add code to avoid block 0 appearing to be in a buffer from COLD.
+* Usually, there is no sector 0 (?), but the RAM buffers are too simple.
+* Note that without this block number being made illegal,
+* about 8 binaryMegabytes (256 bytes/block) of disk can be addressed total.
+* With this block number made illegal, the max is 1 block less,
+* still about 8 biMeg.
+ FCB $8B
+ FCC 'KILL-BUFFE' ; 'KILL-BUFFER'
+ FCB $D2
+ FDB UPDATE-9
+KILBUF FDB *+NATWID ; DOCOL,UPDBIT,ONE,SUB,SWAP,STORE
+ PULU X
+ LDD UPDBIT+NATWID,PCR
+ SUBD #1
+ STD ,X
+* LBSR DBGREG
+ RTS
+*
+ FCB $8C
+ FCC 'KILL-BUFFER' ; 'KILL-BUFFERS'
+ FCB $D3
+ FDB KILBUF-14
+KLBFS FDB *+NATWID
+ LDD #4
+ PSHU D
+ LDD FIRST+NATWID,PCR
+* INC <TRACEM
+* LBSR DBGREG
+ PSHU D ; DUP
+KLBFSL PSHU D
+ BSR KILBUF+NATWID
+ LDD ,U
+* LBSR DBGREG
+ ADDD BBUF+NATWID,PCR
+ ADDD BCTL+NATWID,PCR
+ STD ,U
+* LBSR DBGREG
+ DEC NATWID+1,U
+ BNE KLBFSL
+* LBSR DBGREG
+ LEAU NATWID*2,U
+* DEC <TRACEM
+ RTS
+*
+* ( --- )
+* Erase and mark all buffers empty.
+* Standard method of discarding changes.
+ FCB $8D
+ FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
+ FCB $D3
+ FDB KLBFS-15
+MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
+* FDB FIRST,DUP,KILBUF,PBUF,DROP,DUP,KILBUF
+* FDB PBUF,DROP,DUP,KILBUF,PBUF,DROP,KILBUF
+ FDB KLBFS
+ FDB SEMIS
+*
+* ======>> 173 <<
+* ( --- )
+* Clear the current offset to the block numbers in the drive interface.
+* The drives need to be re-architected.
+* Would be cool to have RAM and ROM drives supported
+* in addition to regular physical persistent store.
+ FCB $83
+ FCC 'DR' ; 'DR0'
+ FCB $B0
+ FDB MTBUF-16
+DRZERO FDB DOCOL,ZERO,OFSET,STORE
+ FDB SEMIS
+*
+* ======>> 174 <<== system dependant word
+* ( --- )
+* Set the current offset in the drive interface to reference the second drive.
+* The hard-coded number in there needs to be in a table.
+ FCB $83
+ FCC 'DR' ; 'DR1'
+ FCB $B1
+ FDB DRZERO-6
+DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
+; **** hard-codes the size of the disc !!!!
+ FDB SEMIS
+*
+* ######>> screen 59 <<
+* ======>> 175 <<
+* ( n --- buffer )
+* Get a free buffer,
+* assign it to block n,
+* return buffer address.
+* Will free a buffer by writing it, if necessary.
+* Does not actually read the block.
+* A bug in the fig LRU algorithm, which I have not fixed,
+* gives the PREVious buffer if USE gets set to PREVious.
+* (The bug is that USE sometimes gets set to PREVious.)
+* This bug sometimes causes sector moves to become sector fills.
+ FCB $86
+ FCC 'BUFFE' ; 'BUFFER'
+ FCB $D2
+ FDB DRONE-6
+BUFFER FDB DOCOL,USE,AT,DUP,TOR
+BUFFR2 FDB PBUF,ZBRAN
+ FDB BUFFR2-*-NATWID
+ FDB USE,STORE,R,AT,ZLESS
+ FDB ZBRAN
+ FDB BUFFR3-*-NATWID
+* FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
+ FDB R,NATP,R,AT,UPDBIT,LNOT,AND,ZERO,RW
+* BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
+BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
+ FDB SEMIS
+*
+* ######>> screen 60 <<
+* ======>> 176 <<
+* ( n --- buffer )
+* Get BUFFER containing block n, relative to OFFSET.
+* If block n is not in a buffer, bring it in.
+* Returns buffer address.
+ FCB $85
+ FCC 'BLOC' ; 'BLOCK'
+ FCB $CB
+ FDB BUFFER-9
+BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
+ FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
+ FDB BLOCK5-*-NATWID
+BLOCK3 FDB PBUF,ZEQU,ZBRAN
+ FDB BLOCK4-*-NATWID
+* FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
+ FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
+BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
+ FDB BLOCK3-*-NATWID
+ FDB DUP,PREV,STORE
+* BLOCK5 FDB FROMR,DROP,TWOP
+BLOCK5 FDB FROMR,DROP,NATP
+ FDB SEMIS
+*
+* ######>> screen 61 <<
+* ======>> 177 <<
+* ( line screen --- buffer C/L)
+* Bring in the sector containing the specified line of the specified screen.
+* Returns the buffer address and the width of the screen.
+* Screen number is relative to OFFSET.
+* The line number may be beyond screen 4,
+* (LINE) will get the appropriate screen.
+ FCB $86
+ FCC '(LINE' ; '(LINE)'
+ FCB $A9
+ FDB BLOCK-8
+PLINE FDB DOCOL,TOR,LIT8
+ FCB $40
+ FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
+ FCB $40
+ FDB SEMIS
+*
+* ======>> 178 <<
+* ( line screen --- )
+* Print the line of the screen as found by (LINE), suppress trailing BLANKS.
+ FCB $85
+ FCC '.LIN' ; '.LINE'
+ FCB $C5
+ FDB PLINE-9
+DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
+ FDB SEMIS
+*
+* ======>> 179 <<
+* ( n --- )
+* If WARNING is 0, print "MESSAGE #n";
+* otherwise, print line n relative to screen 4,
+* the line number may be negative.
+* Uses .LINE, but counter-adjusts to be relative to the real drive 0.
+ FCB $87
+ FCC 'MESSAG' ; 'MESSAGE'
+ FCB $C5
+ FDB DLINE-8
+MESS FDB DOCOL,WARN,AT,ZBRAN
+ FDB MESS3-*-NATWID
+ FDB DDUP,ZBRAN
+ FDB MESS3-*-NATWID
+ FDB LIT8
+ FCB 4
+ FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
+ FDB MESS4-*-NATWID
+MESS3 FDB PDOTQ
+ FCB 6
+ FCC 'err # ' ; 'err # '
+ FDB DOT
+MESS4 FDB SEMIS
+*
+* ======>> 180 <<
+* ( n --- )
+* Begin interpretation of screen (block) n.
+* See also ARROW, SEMIS, and NULL.
+ FCB $84
+ FCC 'LOA' ; 'LOAD' : input:scr #
+ FCB $C4
+ FDB MESS-10
+LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
+ FDB BSCR,STAR,BLK,STORE
+ FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
+ FDB SEMIS
+*
+* ======>> 181 <<
+* ( --- ) P
+* Continue interpreting source code on the next screen.
+ FCB $C3
+ FCC '--' ; '-->'
+ FCB $BE
+ FDB LOAD-7
+ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
+ FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
+ FDB SEMIS
+ PAGE
+*
+*
+* ######>> screen 63 <<
+* The next 4 subroutines are machine dependent, and are
+* called by words 13 through 16 in the dictionary.
+*
+* ======>> 182 << code for EMIT
+* ( --- ) No parameter stack effect.
+* Interfaces directly with ROM. Expects output character in D (therefore, B).
+* Output using rom CHROUT: redirectable to a printer on Coco.
+* Outputs the character on stack (low byte of 1 bit word/cell).
+PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.)
+ TFR B,A ; Coco ROM wants it in A.
+ CLRB
+ TFR B,DP ; Give the ROM its direct page.
+ JSR [$A002] ; Output the character in A.
+ PULS Y,U,DP,PC
+* PEMIT STB N save B
+* STX N+1 save X
+* LDB ACIAC
+* BITB #2 check ready bit
+* BEQ PEMIT+4 if not ready for more data
+* STA ACIAD
+* LDX UP
+* STB IOSTAT-UORIG,X
+* LDB N recover B & X
+* LDX N+1
+* RTS only A register may change
+* PEMIT JMP $E1D1 for MIKBUG
+* PEMIT FCB $3F,$11,$39 for PROTO
+* PEMIT JMP $D286 for Smoke Signal DOS
+*
+* ======>> 183 << code for KEY
+* ( --- ) No parameter stack effect.
+* Returns character or break flag in D, since this interfaces with Coco ROM.
+* Wait for key from POLCAT on Coco.
+* Returns the character code for the key pressed.
+PKEY PSHS Y,U,DP ; Must save everything important for this one.
+ LDA #$CF ; a cursor of sorts
+ CLRB
+ TFR B,DP
+ SETDP 0
+ LDX <$88 ; location
+ LDB ,X ; save glyph
+ STA ,X
+PKEYLP JSR [$A000]
+* STA $41A ; DBG!
+ BEQ PKEYLP
+* STD $418 ; DBG!
+ STB ,X ; restore
+PKEYR CLRB ; for the break flag, shares code with PQTER
+ CMPA #3 ; break key
+ BNE PKEYGT
+ COMB ; for the break flag
+PKEYGT EXG A,B ; Leave it in D for return.
+ PULS Y,U,DP,PC ; Shares exit with PQTER
+ SETDP IUPDP
+* PKEY STB N
+* STX N+1
+* LDB ACIAC
+* ASRB ;
+* BCC PKEY+4 no incoming data yet
+* LDA ACIAD
+* ANDA #$7F strip parity bit
+* LDX UP
+* STB IOSTAT+1-UORIG,X
+* LDB N
+* LDX N+1
+* RTS
+* PKEY JMP $E1AC for MIKBUG
+* PKEY FCB $3F,$14,$39 for PROTO
+* PKEY JMP $D289 for Smoke Signal DOS
+*
+* ######>> screen 64 <<
+* ======>> 184 << code for ?TERMINAL
+* ( --- f ) Should change this to no stack effect.
+* check break key using POLCAT
+* Returns a flag to tell whether the break key was pressed or not.
+PQTER PSHS Y,U,DP
+ CLRB
+ TFR B,DP
+ JSR [$A000] ; Look but don't wait.
+ BRA PKEYR
+* PQTER LDA ACIAC Test for 'break' condition
+* ANDA #$11 mask framing error bit and
+* input buffer full
+* BEQ PQTER2
+* LDA ACIAD clear input buffer
+* LDA #01
+* PQTER2 RTS
+
+
+ PAGE
+*
+* ======>> 185 << code for CR
+* ( --- ) No stack effect.
+* Interfaces directly with ROM.
+* For Coco just output a CR.
+* Also subject to redirection in Coco BASIC ROM.
+PCR LDB #$0D
+ BRA PEMIT ; Just steal the code.
+* PCR LDA #$D carriage return
+* BSR PEMIT
+* LDA #$A line feed
+* BSR PEMIT
+* LDA #$7F rubout
+* LDX UP
+* LDB XDELAY+1-UORIG,X
+* PCR2 DECB ;
+* BMI PQTER2 return if minus
+* PSHS B ; save counter
+* BSR PEMIT print RUBOUTs to delay.....
+* PULS B ;
+* BRA PCR2 repeat
+
+
+ PAGE
+*
+* ######>> screen 66 <<
+* ======>> 187 <<
+* ( ??? )
+* Query the disk, I suppose.
+* Not sure what the model had in mind for this stub.
+ FCB $85
+ FCC '?DIS' ; '?DISC'
+ FCB $C3
+ FDB ARROW-6
+QDISC FDB *+NATWID
+ JMP NEXT
+*
+* ######>> screen 67 <<
+* ======>> 189 <<
+* ( ??? )
+* Write one block of data to disk.
+* Parameters unspecified in model. Stub in model.
+ FCB $8B
+ FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
+ FCB $C5
+ FDB QDISC-8
+BWRITE FDB *+NATWID
+ JMP NEXT
+*
+* ######>> screen 68 <<
+* ======>> 190 <<
+* ( ??? )
+* Read one block of data from disk.
+* Parameters unspecified in model. Stub in model.
+ FCB $8A
+ FCC 'BLOCK-REA' ; 'BLOCK-READ'
+ FCB $C4
+ FDB BWRITE-14
+BREAD FDB *+NATWID
+ JMP NEXT
+*
+*The next 3 words are written to create a substitute for disc
+* mass memory,located between MASSLO & MASSHI in ram --
+* ($3210 and $3fff in the 6800 model).
+* ======>> 190.1 <<
+ FCB $82
+ FCC 'L' ; 'LO'
+ FCB $CF
+ FDB BREAD-13
+LO FDB DOCON
+ FDB MEMEND a system dependent equate at front
+*
+* ======>> 190.2 <<
+ FCB $82
+ FCC 'H' ; 'HI'
+ FCB $C9
+ FDB LO-5
+HI FDB DOCON
+ FDB MEMTOP ( $3FFF or $7FFF in this version )
+*
+* ######>> screen 69 <<
+* ======>> 191 <<
+* ( buffer sector f --- )
+* Read or Write the specified (absolute -- ignores OFFSET) sector
+* from or to the specified buffer.
+* A zero flag specifies write,
+* non-zero specifies read.
+* Sector is an unsigned integer,
+* buffer is the buffer's address.
+* Will need to use the CoCo ROM disk routines.
+* For now, provides a virtual disk in RAM.
+ FCB $83
+ FCC 'R/' ; 'R/W'
+ FCB $D7
+ FDB HI-5
+RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
+ FDB RW2-*-NATWID
+ FDB PDOTQ
+ FCB 8
+ FCC ' Range ?' ; ' Range ?'
+ FDB QUIT
+RW2 FDB FROMR,ZBRAN
+ FDB RW3-*-NATWID
+ FDB SWAP
+RW3 FDB BBUF,CMOVE
+ FDB SEMIS
+*
+* From BIF-6809:
+* RW PSHS Y,U,DP
+* LDY $C006 control table
+* LDX #DROFFS+7 ; This is BIF's table of drive sizes.
+* LDD 2,U
+* RWD SUBD ,X++ sectors
+* BHS RWD
+* BVC RWR table end?
+* LDD #6
+* PSHU D
+* JMP ERROR
+* RWR ADDD ,--X back one
+* PSHS X
+* PSHU D
+* LDD #18 sectors/track
+* PSHU D
+* DOCOL
+* FDB SLAMOD
+* FDB XMACH
+* PULU D
+* STB 2,Y track
+* PULU D
+* INCB
+* STB 3,Y sector
+* PULS D table entry
+* SUBD #DROFFS+7
+* ASRB drive #
+* STB 1,Y
+* LDD 4,U buffer
+* STD 4,Y
+* LDB #2 coco READ
+* LDX ,U 0?
+* BNE *+3
+* INCB coco WRITE
+* STB ,Y op code
+* CLRA
+* TFR A,DP
+* JSR [$C004] ROM handles timeout
+* PULS Y,U,DP if IRQ enabled
+* LEAU 6,U
+* LDX $C006
+* LDB 6,X coco status
+* BEQ RWE
+* LDX <UP
+* LDD #0 no disc
+* STD UWARN,X
+* LDD #8
+* PSHU D
+* JMP ERROR
+* RWE NEXT
+*
+* ######>> screen 72 <<
+* ======>> 192 <<
+* ( --- ) compiling P
+* ( --- adr ) interpreting
+* { ' name } input
+* Parse a symbol name from input and search the dictionary for it, per -FIND;
+* compile the address as a literal if compiling,
+* otherwise just push it.
+ FCB $C1 immediate
+ FCB $A7 ' ( tick )
+ FDB RW-6
+TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
+ FDB SEMIS
+*
+* ======>> 193 <<
+* ( --- ) { FORGET name } input
+* Parse out name of definition to FORGET to, -DFIND it,
+* then lop it and everything that follows out of the dictionary.
+* In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
+ FCB $86
+ FCC 'FORGE' ; 'FORGET'
+ FCB $D4
+ FDB TICK-4
+FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
+ FCB $18
+ FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT8
+ FCB $15
+ FDB QERR,DUP,ZERO,PORIG,GREAT,LIT8
+ FCB $15
+ FDB QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
+ FDB SEMIS
+*
+* ######>> screen 73 <<
+* ======>> 194 <<
+* ( adr --- ) C
+* Calculate a back reference from HERE and compile it.
+ FCB $84
+ FCC 'BAC' ; 'BACK'
+ FCB $CB
+ FDB FORGET-9
+* BACK FDB DOCOL,HERE,SUB,COMMA
+BACK FDB DOCOL,HERE,NATP,SUB,COMMA
+ FDB SEMIS
+*
+* ======>> 195 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop test UNTIL
+* typical use: BEGIN code-loop AGAIN
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* ( --- adr n ) compile time P,C
+* Push HERE for BACK reference for general (non-counting) loops,
+* with BEGIN construct flag.
+* A better flag: $4245 (ASCII for 'BE').
+ FCB $C5
+ FCC 'BEGI' ; 'BEGIN'
+ FCB $CE
+ FDB BACK-7
+BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
+ FDB SEMIS
+*
+* ======>> 196 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ENDIF is just a sort of intersection piece,
+* marking where execution resumes after both branches.
+* ( adr n --- ) compile time
+* Check the mark and resolve the IF.
+* A better flag: $4846 (ASCII for 'IF').
+ FCB $C5
+ FCC 'ENDI' ; 'ENDIF'
+ FCB $C6
+ FDB BEGIN-8
+ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
+ FDB OVER,NATP,SUB,SWAP,STORE
+ FDB SEMIS
+*
+* ======>> 197 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ( adr n --- )
+* Alias for ENDIF .
+ FCB $C4
+ FCC 'THE' ; 'THEN'
+ FCB $CE
+ FDB ENDIF-8
+THEN FDB DOCOL,ENDIF
+ FDB SEMIS
+*
+* ======>> 198 <<
+* ( limit index --- ) runtime
+* typical use: DO code-loop LOOP
+* typical use: DO code-loop increment +LOOP
+* Counted loop, index is initial value of index.
+* Will loop until index equals (positive going)
+* or passes (negative going) limit.
+* ( --- adr n ) compile time P,C
+* Compile (DO), push HERE for BACK reference,
+* and push DO control construct flag.
+* A better flag: $444F (ASCII for 'DO').
+ FCB $C2
+ FCC 'D' ; 'DO'
+ FCB $CF
+ FDB THEN-7
+DO FDB DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
+ FDB SEMIS
+*
+* ======>> 199 <<
+* ( --- ) runtime
+* typical use: DO code-loop LOOP
+* Increments the index by one and branches back to beginning of loop.
+* Will loop until index equals limit.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (LOOP), fill in BACK reference.
+* A better flag: $444F (ASCII for 'DO').
+ FCB $C4
+ FCC 'LOO' ; 'LOOP'
+ FCB $D0
+ FDB DO-5
+LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
+ FDB SEMIS
+*
+* ======>> 200 <<
+* ( n --- ) runtime
+* typical use: DO code-loop increment +LOOP
+* Increments the index by n and branches back to beginning of loop.
+* Will loop until index equals (positive going)
+* or passes (negative going) limit.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (+LOOP), fill in BACK reference.
+* A better flag: $444F (ASCII for 'DO').
+ FCB $C5
+ FCC '+LOO' ; '+LOOP'
+ FCB $D0
+ FDB LOOP-7
+PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
+ FDB SEMIS
+*
+* ======>> 201 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test UNTIL
+* Will loop until UNTIL tests true.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (0BRANCH), fill in BACK reference.
+* A better flag: $4245 (ASCII for 'BE').
+ FCB $C5
+ FCC 'UNTI' ; 'UNTIL' : ( same as END )
+ FCB $CC
+ FDB PLOOP-8
+UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
+ FDB SEMIS
+*
+* ######>> screen 74 <<
+* ======>> 202 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test END
+* ( adr n --- )
+* Alias for UNTIL .
+ FCB $C3
+ FCC 'EN' ; 'END'
+ FCB $C4
+ FDB UNTIL-8
+END FDB DOCOL,UNTIL
+ FDB SEMIS
+*
+* ======>> 203 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop AGAIN
+* Will loop forever
+* (or until something uses R> DROP to force the current definition to die,
+* or perhaps ABORT or ERROR or some such other drastic means stops things).
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (0BRANCH), fill in BACK reference.
+* A better flag: $4245 (ASCII for 'BE').
+ FCB $C5
+ FCC 'AGAI' ; 'AGAIN'
+ FCB $CE
+ FDB END-6
+AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
+ FDB SEMIS
+*
+* ======>> 204 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* Will loop until WHILE tests false, skipping code-true on end.
+* REPEAT marks where execution resumes after the WHILE find a false flag.
+* ( aadr1 n1 adr2 n2 --- ) compile time P,C
+* Check the marks for WHILE and BEGIN,
+* compile BRANCH and BACK fill adr1 reference,
+* FILL-IN 0BRANCH reference at adr2.
+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+ FCB $C6
+ FCC 'REPEA' ; 'REPEAT'
+ FCB $D4
+ FDB AGAIN-8
+REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
+ FDB TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
+ FDB SEMIS
+*
+* ======>> 205 <<
+* ( n --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* Will pass execution to the true part on a true flag
+* and to the false part on a false flag.
+* ( --- adr n ) compile time P,C
+* Compile a 0BRANCH and dummy offset
+* and push IF reference to fill in and
+* IF control construct flag.
+* A better flag: $4946 (ASCII for 'IF').
+ FCB $C2
+ FCC 'I' ; 'IF'
+ FCB $C6
+ FDB REPEAT-9
+IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
+ FDB SEMIS
+*
+* ======>> 206 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ELSE is just a sort of intersection piece,
+* marking where execution resumes on a false branch.
+* ( adr1 n --- adr2 n ) compile time P,C
+* Check the marks,
+* compile BRANCH with dummy offset,
+* resolve IF reference,
+* and leave reference to BRANCH for ELSE.
+* A better flag: $4946 (ASCII for 'IF').
+ FCB $C4
+ FCC 'ELS' ; 'ELSE'
+ FCB $C5
+ FDB IF-5
+ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
+ FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
+ FDB SEMIS
+*
+* ======>> 207 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* Will loop until WHILE tests false, skipping code-true on end.
+* ( --- adr n ) compile time P,C
+* Compile 0BRANCH with dummy offset (using IF),
+* push WHILE reference.
+* BEGIN flag will sit underneath this.
+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+ FCB $C5
+ FCC 'WHIL' ; 'WHILE'
+ FCB $C5
+ FDB ELSE-7
+WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
+ FDB SEMIS
+*
+* ######>> screen 75 <<
+* ======>> 208 <<
+* ( count --- )
+* EMIT count spaces, for non-zero, non-negative counts.
+ FCB $86
+ FCC 'SPACE' ; 'SPACES'
+ FCB $D3
+ FDB WHILE-8
+SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
+ FDB SPACE3-*-NATWID
+ FDB ZERO,XDO
+SPACE2 FDB SPACE,XLOOP
+ FDB SPACE2-*-NATWID
+SPACE3 FDB SEMIS
+*
+* ======>> 209 <<
+* ( --- )
+* Initialize HLD for converting a double integer.
+* Stores the PAD address in HLD.
+ FCB $82
+ FCC '<' ; '<#'
+ FCB $A3
+ FDB SPACES-9
+BDIGS FDB DOCOL,PAD,HLD,STORE
+ FDB SEMIS
+*
+* ======>> 210 <<
+* ( d --- string length )
+* Terminate numeric conversion,
+* drop the number being converted,
+* leave the address of the conversion string and the length, ready for TYPE.
+ FCB $82
+ FCC '#' ; '#>'
+ FCB $BE
+ FDB BDIGS-5
+EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
+ FDB SEMIS
+*
+* ======>> 211 <<
+* ( n d --- d )
+* Put sign of n (as a flag) at the head of the conversion string.
+* Drop the sign flag.
+ FCB $84
+ FCC 'SIG' ; 'SIGN'
+ FCB $CE
+ FDB EDIGS-5
+SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
+ FDB SIGN2-*-NATWID
+ FDB LIT8
+ FCC "-"
+ FDB HOLD
+SIGN2 FDB SEMIS
+*
+* ======>> 212 <<
+* ( d --- d/base )
+* Generate next most significant digit in the conversion BASE,
+* putting the digit at the head of the conversion string.
+ FCB $81 #
+ FCB $A3
+ FDB SIGN-7
+DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
+ FCB 9
+ FDB OVER,LESS,ZBRAN
+ FDB DIG2-*-NATWID
+ FDB LIT8
+ FCB 7
+ FDB PLUS
+DIG2 FDB LIT8
+ FCC "0" ascii zero
+ FDB PLUS,HOLD
+ FDB SEMIS
+*
+* ======>> 213 <<
+* ( d --- dzero )
+* Convert d to a numeric string using # until the result is zero.
+* Leave the double result on the stack for #> to drop.
+ FCB $82
+ FCC '#' ; '#S'
+ FCB $D3
+ FDB DIG-4
+DIGS FDB DOCOL
+DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
+ FDB DIGS2-*-NATWID
+ FDB SEMIS
+*
+* ######>> screen 76 <<
+* ======>> 214 <<
+* ( n width --- )
+* Print n on the output device in the current conversion base,
+* with sign,
+* right aligned in a field at least width wide.
+ FCB $82
+ FCC '.' ; '.R'
+ FCB $D2
+ FDB DIGS-5
+DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
+ FDB SEMIS
+*
+* ======>> 215 <<
+* ( d width --- )
+* Print d on the output device in the current conversion base,
+* with sign,
+* right aligned in a field at least width wide.
+ FCB $83
+ FCC 'D.' ; 'D.R'
+ FCB $D2
+ FDB DOTR-5
+DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
+ FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
+ FDB SEMIS
+*
+* ======>> 216 <<
+* D. ( d --- )
+* Print d on the output device in the current conversion base,
+* with sign,
+* in free format with trailing space.
+ FCB $82
+ FCC 'D' ; 'D.'
+ FCB $AE
+ FDB DDOTR-6
+DDOT FDB DOCOL,ZERO,DDOTR,SPACE
+ FDB SEMIS
+*
+* ======>> 217 <<
+* ( n --- )
+* Print n on the output device in the current conversion base,
+* with sign,
+* in free format with trailing space.
+ FCB $81 .
+ FCB $AE
+ FDB DDOT-5
+DOT FDB DOCOL,STOD,DDOT
+ FDB SEMIS
+*
+* ======>> 218 <<
+* ( adr --- )
+* Print signed word at adr, per DOT.
+ FCB $81 ?
+ FCB $BF
+ FDB DOT-4
+QUEST FDB DOCOL,AT,DOT
+ FDB SEMIS
+*
+* ######>> screen 77 <<
+* ======>> 219 <<
+* ( n --- )
+* Print out screen n as a field of ASCII,
+* with line numbers in decimal.
+* Needs a console more than 70 characters wide.
+ FCB $84
+ FCC 'LIS' ; 'LIST'
+ FCB $D4
+ FDB QUEST-4
+LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
+ FCB 6
+ FCC "SCR # "
+ FDB DOT,LIT8
+ FCB $10
+ FDB ZERO,XDO
+LIST2 FDB CR,I,THREE
+ FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
+ FDB LIST2-*-NATWID
+ FDB CR
+ FDB SEMIS
+*
+* ======>> 220 <<
+* ( start end --- )
+* Print comment lines (line 0, and line 1 if C/L < 41) of screens
+* from start to end.
+* Needs a console more than 70 characters wide.
+ FCB $85
+ FCC 'INDE' ; 'INDEX'
+ FCB $D8
+ FDB LIST-7
+INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
+INDEX2 FDB CR,I,THREE
+ FDB DOTR,SPACE,ZERO,I,DLINE
+ FDB QTERM,ZBRAN
+ FDB INDEX3-*-NATWID
+ FDB LEAVE
+INDEX3 FDB XLOOP
+ FDB INDEX2-*-NATWID
+ FDB SEMIS
+*
+* ======>> 221 <<
+* ( n --- )
+* List a printer page full of screens.
+* Line and screen number are in current base.
+* Needs a console more than 70 characters wide.
+ FCB $85
+ FCC 'TRIA' ; 'TRIAD'
+ FCB $C4
+ FDB INDEX-8
+TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
+ FDB THREE,OVER,PLUS,SWAP,XDO
+TRIAD2 FDB CR,I
+ FDB LIST,QTERM,ZBRAN
+ FDB TRIAD3-*-NATWID
+ FDB LEAVE
+TRIAD3 FDB XLOOP
+ FDB TRIAD2-*-NATWID
+ FDB CR,LIT8
+ FCB $0F
+ FDB MESS,CR
+ FDB SEMIS
+*
+* ######>> screen 78 <<
+* ======>> 222 <<
+* ( --- )
+* Alphabetically list the definitions in the current vocabulary.
+* Expects to output to printer, not TRS80 Color Computer screen.
+ FCB $85
+ FCC 'VLIS' ; 'VLIST'
+ FCB $D4
+ FDB TRIAD-8
+VLIST FDB DOCOL,LIT8
+ FCB $80
+ FDB OUT,STORE,CONTXT,AT,AT
+VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
+ FCB 32
+ FDB SUB,GREAT,ZBRAN
+ FDB VLIST2-*-NATWID
+ FDB CR,ZERO,OUT,STORE
+VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
+ FDB DUP,ZEQU,QTERM,OR,ZBRAN
+ FDB VLIST1-*-NATWID
+ FDB DROP
+ FDB SEMIS
+*
+* Need some utility stuff that isn't in the fig FORTH:
+* ( c --- )
+* Emit dot if c is less than blank, else emit c
+ FCB $85
+ FCC 'BEMI' ; 'BEMIT'
+ FCB $D4 ; 'T'
+ FDB VLIST-8
+BEMIT FDB DOCOL
+ FDB DUP,BL,LESS,ZBRAN
+ FDB BEMITO-*-NATWID
+ FDB DROP,LIT8
+ FCB $2e ; '.'
+BEMITO FDB EMIT
+ FDB SEMIS
+*
+* ( n width --- )
+* Output n in hexadecimal field width.
+ FCB $83
+ FCC 'X.' ; 'X.R'
+ FCB $D2 ; 'R'
+ FDB BEMIT-8
+XDOTR FDB DOCOL
+ FDB BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
+ FDB SEMIS
+*
+* ( adr --- )
+* Dump a line of 4 bytes in memory, in hex and as characters.
+ FCB $85
+ FCC 'BLIN' ; 'BLINE'
+ FCB $C5 ; 'E'
+ FDB XDOTR-6
+BLINE FDB DOCOL
+ FDB DUP,LIT8
+ FCB 4
+ FDB PLUS,OVER,XDO
+BLINEX FDB I,CAT,THREE,XDOTR,XLOOP
+ FDB BLINEX-*-NATWID
+ FDB SPACE,SPACE
+ FDB DUP,LIT8
+ FCB 4
+ FDB PLUS,SWAP,XDO
+BLINEC FDB I,CAT,BEMIT,XLOOP
+ FDB BLINEC-*-NATWID
+ FDB SEMIS
+*
+* ( start end --- )
+* Dump 4 byte lines from start to end.
+ FCB $85
+ FCC 'BDUM' ; 'BDUMP'
+ FCB $D0 ; '5'
+ FDB BLINE-8
+BDUMP FDB DOCOL
+ FDB CR,XDO
+BDUMPL FDB I,LIT8
+ FCB 4
+ FDB XDOTR,LIT8
+ FCB $3A
+ FDB EMIT,SPACE
+ FDB I,BLINE,CR,LIT8
+ FCB 4
+ FDB XPLOOP
+ FDB BDUMPL-*-NATWID
+ FDB SEMIS
+*
+* ======>> XX <<
+* ( --- )
+* Mostly for place holding (fig Forth).
+ FCB $84
+ FCC 'NOO' ; 'NOOP'
+ FCB $D0
+ FDB BDUMP-8
+NOOP FDB *+NATWID
+ RTS
+* Without the RTS, would misalign the stack.
+* NOOP NEXT a useful no-op
+ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
+
+ PAGE
+* These things, up through the lable 'REND', are overwritten
+* at time of cold load and should have the same contents
+* as shown here:
+*
+* This can be moved whereever the bottom of the
+* user's dictionary is going to be put.
+*
+RBEG EQU *
+ FCB $C5 immediate
+ FCC 'FORT' ; 'FORTH'
+ FCB $C8
+ FDB NOOP-7
+FORTH FDB DODOES,DOVOC,$81A0,TASK-7
+ FDB 0
+*
+ FCC "Copyright 1979 Forth Interest Group, David Lion,"
+ FCB $0D
+ FCC "Parts Copyright 2019 Joel Matthew Rees"
+ FCB $0D
+*
+ FCB $84
+ FCC 'TAS' ; 'TASK'
+ FCB $CB
+ FDB FORTH-8
+TASK FDB DOCOL,SEMIS
+*
+REND EQU * ( first empty location in dictionary )
+RSIZE EQU *-RBEG ; So we can look at it.
+ PAGE
+
+ ORG RAMDSK
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " 0) Index page " ; 0
+ FCC " 1) empty line on line 1 of screen 0 block 0 " ; 1
+ FCC " 2) Title and copyright " ; 2
+ FCC " 3) empty line on line 3 of screen 0 block 0 " ; 3
+ FCC " 4) Error messages 1st screen " ; 4
+ FCC " 5) Error messages 2nd screen " ; 5
+ FCC " 6) empty line 3 screen 0 block 1 " ; 6
+ FCC " 7) empty line 4 " ; 7
+ FCC " 8) and line 1 of block 2 " ; 8
+ FCC " 9) line 2 of block 2 screen 0 is pretty much empty too " ; 9
+ FCC " 10) listen to this. Line three of block two is too " ; 10
+ FCC " 11) and so is line 4 4 4 4 4 4 4 4 4 4 b2s0 " ; 11
+ FCC " 12) screen zero block three first line " ; 12
+ FCC " 13) second line fourth block (block three) screen 0 " ; 13
+ FCC " 14) block three screen zero line 3 3 3 3 3 3 3 3 3 " ; 14
+ FCC " 15) fourth line block three screen 0 0 0 0 0 0 0 0 0 0 " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " test 10 b0s1 aaaa " ; 0
+ FCC " test 11 b0s1 ee ee ee ee " ; 1
+ FCC " test 12 b0s1 oo oo oo oo oo " ; 2
+ FCC " test 13 b0s1 eh ehe he eh eh " ; 3
+ FCC " ( block 1 ) b1s1 oh ohoo oh oh oh " ; 4
+ FCC " 15 test b1s1 " ; 5
+ FCC " 16 test b1s1 " ; 6
+ FCC " 17 test b1s1 " ; 7
+ FCC " 18 test b2s1 " ; 8
+ FCC " 19 test b2s1 " ; 9
+ FCC " 1A test b2s1 " ; 10
+ FCC " 1B test b2ws1 " ; 11
+ FCC " 1C test b3s1 " ; 12
+ FCC " 1D test b3s1 " ; 13
+ FCC " 1e this completes our second screen b3s1 " ; 14
+ FCC " 1F test b3s1 " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " " ; 0
+ FCC " fig Forth High Level Model Code " ; 1
+ FCC " " ; 2
+ FCC " Copyright 2018 Joel Matthew Rees " ; 3
+ FCC " ( block 2 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " " ; 0
+ FCC " " ; 1
+ FCC " " ; 2
+ FCC " " ; 3
+ FCC " ( block 3 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " " ; 0
+ FCC " " ; 1
+ FCC " " ; 2
+ FCC " " ; 3
+ FCC " ( block 4 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " ( ERROR MESSAGES ) " ; 0
+ FCC " DATA STACK UNDERFLOW " ; 1
+ FCC " DICTIONARY FULL " ; 2
+ FCC " ADDRESS RESOLUTION ERROR " ; 3
+ FCC " HIDES DEFINITION IN " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " more test data 2 3 4 5 6 " ; 0
+ FCC "0123456789012345678901234567890123456789012345678901234567890123" ; 1
+ FCC "Test data for the RAM disc emulator buffers. " ; 2
+ FCC " " ; 3
+ FCC " ( block 6 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " end" ; 15
+RAMDND EQU *
+
+
+ PAGE
+ OPT L
+ END
OSDN Git Service
