OPT PRT
-* fig-FORTH FOR 6800
+* fig-FORTH FOR 6809
* ASSEMBLY SOURCE LISTING
-* RELEASE 1
-* MAY 1979
+* 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 public domain publication is provided
+* 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
+ NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
OPT NOG,PAG
-* filename FTH7.21
-* === FORTH-6800 06-06-79 21:OO
+* 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.
-* This listing is in the PUBLIC DOMAIN and
-* may be freely copied or published with the
-* restriction that a credit line is printed
-* with the material, crediting the
-* authors and the FORTH INTEREST GROUP.
+* 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.
+*
-* === by Dave Lion,
+* Authors of the 6800 model:
+* === Primary: Dave Lion,
* === with help from
* === Bob Smith,
* === LaFarr Stuart,
* === 1134-K Aster Ave.
* === Sunnyvale, CA 94086
*
-* This version was developed on an AMI EVK 300 PROTO
-* system using an ACIA for the I/O. All terminal 1/0
+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 been
+* of the FORTH Interest Group, but have not yet been
* tested using a real disc.
*
-* Addresses in this implementation reflect the fact that,
+* 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
* 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.
+*
-
-*
-NBLK EQU 4 # of disc buffer blocks for virtual memory
-MEMEND EQU 132*NBLK+$3000 end of ram
-* each block is 132 bytes in size,
-* holding 128 characters
*
-MEMTOP EQU $3FFF absolute end of all ram
+MEMT32 EQU $7FFF absolute end of all ram
+MEMT16 EQU $3FFF
+MEMTOP EQU MEMT16 ; tentative guess
ACIAC EQU $FBCE the ACIA control address and
ACIAD EQU ACIAC+1 data address for PROTO
PAGE
-* MEMORY MAP for this 16K system:
-* ( positioned so that systems with 4k byte write-
+* 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
* **** ******************************* ******* ******
-* 3FFF HI
+* 2nd through 4th per-user tables
+* 4000|7D00
+USERSZ EQU 256 ; (Addressable by DP)
+USER16 EQU 1 ; We can change these for ROMPACK or 64K.
+USER32 EQU 4
+USERCT EQU USER16
+IUP16 EQU MEMT16+1-USER16*USERSZ
+IUP32 EQU MEMT32+1-USER32*USERSZ
+IUP EQU IUP16
+IUPDP EQU IUP/256
+* user tables of variables
+* registers & pointers for the virtual machine
+* scratch area used by various words
+* 3F00|7C00 <== UP (DICTPT)
+* 3EFF|7BFF HI
* substitute for disc mass memory
-* 3210 LO,MEMEND
-* 320F
+RAMSCR EQU 3
+SCRSZ EQU 1024
+* 3300|7000 LO,MEMEND
+RAMD16 EQU IUP16-RAMSCR*SCRSZ
+RAMD32 EQU IUP32-RAMSCR*SCRSZ
+RAMDSK EQU RAMD16
+MEME16 EQU RAMD16
+MEME32 EQU RAMD32
+MEMEND EQU MEME16
+* 32FF|6FFF
* 4 buffer sectors of VIRTUAL MEMORY
-* 3000 FIRST
-* >>>>>> memory from here up must be RAM <<<<<<
-*
-* 27FF
-* 6k of romable "FORTH" <== IP ABORT
-* <== W
-* the VIRTUAL FORTH MACHINE
-*
-* 1004 <<< WARM START ENTRY >>>
-* 1000 <<< COLD START ENTRY >>>
-*
-* >>>>>> memory from here down must be RAM <<<<<<
-* FFE RETURN STACK base <== RP RINIT
-*
-* FB4
+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 8
+BUFSZ EQU (SECTSZ+SECTRL)*NBLK
+* 2EE0|6BE0 FIRST
+BUFB16 EQU MEME16-BUFSZ
+BUFB32 EQU MEME32-BUFSZ
+BUFBAS EQU BUFB16
+* "end" of "usable ram" -- in 16K
+* 2EE0|6BE0 <== RP RINIT
+IRP16 EQU BUFB16
+IRP32 EQU BUFB32
+IRP EQU IRP16
+* RETURN STACK
+* (64|112 levels nesting)
+RSTK16 EQU 128
+RSTK32 EQU 224
+* (2E60|6B00)
+SFTB16 EQU IRP16-RSTK16
+SFTB32 EQU IRP32-RSTK32
+SFTBND EQU SFTB16
* INPUT LINE BUFFER
-* holds up to 132 characters
+* holds up to 256 characters
* and is scanned upward by IN
* starting at TIB
-* F30 <== IN TIB
-* F2F DATA STACK <== SP SP0,SINIT
-* | grows downward from F2F
+TIBSZ EQU 256
+* 2D60|6A00
+ITIB16 EQU SFTB16-TIBSZ
+ITIB32 EQU SFTB32-TIBSZ
+ITIB EQU ITIB16
+* 2D60|6A00 <== IN TIB
+ISP16 EQU ITIB16
+ISP32 EQU ITIB32
+ISP EQU ISP16
+* 2D60|6A00 <== SP SP0,SINIT
+* DATA STACK
+* | grows downward from 2A60|6A00
* v
* - -
* |
* I DICTIONARY grows upward
*
-* 183 end of ram-dictionary. <== DP DPINIT
+* ???? end of ram-dictionary. <== DICTPT DPINIT
* "TASK"
*
-* 150 "FORTH" ( a word ) <=, <== CONTEXT
+* ???? "FORTH" ( a word ) <=, <== CONTEXT
* `==== CURRENT
-* 148 start of ram-dictionary.
+* start of ram-dictionary.
*
-* 100 user #l table of variables <= UP DPINIT
-* F0 registers & pointers for the virtual machine
-* scratch area used by various words
-* E0 lowest address used by FORTH
+* >>>>>> 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
+*
+* >>>>>> memory from here down left alone <<<<<<
+* >>>>>> so we can safely call ROM routines <<<<<<
*
* 0000
PAGE
*
* CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
*
-* IP points to the current instruction ( pre-increment mode )
-* RP points to second free byte (first free word) in return stack
-* SP (hardware SP) points to first free byte in data stack
+* 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,
+* 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.
+*
***
-
-
-
- ORG $E0 variables
-
+ 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
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 )
*
- PAGE
-* This system is shown with one user, but additional users
-* may be added by allocating additional user tables:
-* UORIG2 RMB 64 data table for user #2
-*
-*
-* Some of this stuff gets initialized during
-* COLD start and WARM start:
-* [ names correspond to FORTH words of similar (no X) name ]
-*
- ORG $100
-UORIG RMB 6 3 reserved variables
+*UORIG 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
-XDP RMB 2 dictionary pointer
+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
RMB 4 ( spares )
PAGE
-* These things, up through the lable 'REND', are overwritten
-* at time of cold load and should have the same contents
-* as shown here:
-*
- FCB $C5 immediate
- FCC 'FORT' ; 'FORTH'
- FCB $C8
- FDB NOOP-7
-FORTH FDB DODOES,DOVOC,$81A0,TASK-7
- FDB 0
-*
- FCC "(C) Forth Interest Group, 1979"
-
- FCB $84
- FCC 'TAS' ; 'TASK'
- FCB $CB
- FDB FORTH-8
-TASK FDB DOCOL,SEMIS
-*
-REND EQU * ( first empty location in dictionary )
-
- PAGE
-* The FORTH program ( address $1000 to $27FF ) is written
-* so that it can be in a ROM, or write-protected if desired
- ORG $1000
+* 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 <<
*
NOP
JMP WENT warm-start code, keeps current dictionary intact
+ SETDP IUPDP
+
*
******* startup parmeters **************************
*
- FDB $6800,0000 cpu & revision
+ FDB $6809,0000 cpu & revision
FDB 0 topmost word in FORTH vocabulary
BACKSP FDB $7F backspace character for editing
UPINIT FDB UORIG initial user area
-SINIT FDB ORIG-$D0 initial top of data stack
-RINIT FDB ORIG-2 initial top of return stack
- FDB ORIG-$D0 terminal input buffer
+* 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 DP
+DPINIT FDB REND cold start value for DICTPT
VOCINT FDB FORTH+8
COLINT FDB 132 initial terminal carriage width
DELINT FDB 4 initial carriage return delay
PAGE
*
* ######>> screen 13 <<
-PULABX PULS A ; 24 cycles until 'NEXT'
- PULS B ;
-STABX STA 0,X 16 cycles until 'NEXT'
- STB 1,X
+* 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
-PUSHBA PSHS B ; 8 cycles until 'NEXT'
- PSHS A ;
-
+* 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 38 cycles if TRACE is removed,
+* "NEXT" takes ?? cycles if TRACE is removed,
*
-* and 95 cycles if NOT tracing.
+* 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 LDX IP
- LEAX 1,X ; pre-increment mode
- LEAX 1,X ;
- STX IP
-NEXT2 LDX 0,X get W which points to CFA of word to be done
-NEXT3 STX W
- LDX 0,X get VECT which points to executable code
+* 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
+* 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
+* 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 )
+* 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
* =
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
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
- FDB 0 link of zero to terminate dictionary scan
-LIT FDB *+2
- LDX IP
- LEAX 1,X ;
- LEAX 1,X ;
- STX IP
- LDA 0,X
- LDB 1,X
- JMP PUSHBA
+ FDB 0 ; link of zero to terminate dictionary scan
+LIT FDB *+NATWID ; Note also that it 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 <<
-CLITER FDB *+2 (this is an invisible word, with no header)
- LDX IP
- LEAX 1,X ;
- STX IP
- CLRA ;
- LDB 1,X
- JMP PUSHBA
+* ( --- 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
*
* ======>> 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 LIT-6
-EXEC FDB *+2
- TFR S,X ; TSX :
- LDX 0,X get code field address (CFA)
- LEAS 1,S ; pop stack
- LEAS 1,S ;
- JMP NEXT3
+ FDB LIT-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
-*
+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 *+2
- PULS A ;
- PULS B ;
- PSHS B ; ** emulating ABA:
- ADDA ,S+ ;
+ZBRAN FDB *+NATWID
+ LDD ,U++
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
+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 *+2
- CLRA ;
- LDB #1 get set to increment counter by 1
- BRA XPLOP2 go steal other guy's code!
+XLOOP FDB *+NATWID
+ LDD #1 ; Borrowing from BIF-6809.
+XLOOPA ADDD 2,S ; Dodge the return address.
+ STD 2,S
+ SUBD 4,S
+ BLT ZBYES ; signed
+XLOOPN LEAY 2,Y
+ LDX ,S ; synthetic return
+ LEAS 6,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 *+2 Note: +LOOP has an un-signed loop counter
- 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
+XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
+ LDD ,U++ ; inc val
+ BPL XLOOPA ; Steal plain loop code for forward count.
+ ADDD 2,S ; Dodge the return address
+ STD 2,S
+ SUBD 4,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
+* 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 *+2 This is the RUNTIME DO, not the COMPILING DO
- 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
+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 *+2
- LDX RP
- LEAX 1,X ;
- LEAX 1,X ;
- JMP GETX
+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 *+2 NOTE: legal input range is 0-9, A-Z
- TFR S,X ; TSX :
- LDA 3,X
- SUBA #$30 ascii zero
+DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
+ LDD 2,U ; Check the whole thing.
+ SUBD #$30 ; ascii zero
BMI DIGIT2 IF LESS THAN '0', ILLEGAL
- CMPA #$A
+ CMPD #$A
BMI DIGIT0 IF '9' OR LESS
- CMPA #$11
+ CMPD #$11
BMI DIGIT2 if less than 'A'
- CMPA #$2B
+ CMPD #$2B
BPL DIGIT2 if greater than 'Z'
- SUBA #7 translate 'A' thru 'F'
-DIGIT0 CMPA 1,X
+ SUBD #7 translate 'A' thru 'F'
+DIGIT0 CMPD ,U ; Check the base.
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
+ STD 2,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 2,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 format in the dictionary is:
+* The word definition format in the dictionary:
+*
+* (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
*
-* char-count + $80 lowest address
-* char 1
+* 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
-* link high byte \___point to previous word
-* link low byte /
-* CFA high byte \___pnt to 6800 code
-* CFA low byte /
-* parameter fields
-* "
-* "
-* "
+* ...
+* 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.
+*
+* But we really want more:
+* 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 less than their name strings.
FCB $86
FCC '(FIND' ; '(FIND)'
FCB $A9
FDB DIGIT-8
-PFIND FDB *+2
- NOP
- 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
-PFIND1 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 PFIND4
-PFIND2 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 PFIND8
- ANDB #$7F clear sign
- PSHS B ; ** emulating CBA:
- CMPA ,S+ ;
- BEQ FOUND
-PFIND3 LDX 0,X get new link
- BNE PFIND1 continue if link not=0
+PFIND FDB *+NATWID
+ PSHS Y ; Have to track two pointers.
+* Use the stack and registers instead of temp area N.
+PA0 EQU 2 ; pointer to the length byte of name being searched against
+PD EQU 0 ; pointer to NFA of dict word being checked
+*
+ 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
+ CMPB ,Y+ ; Compare lengths
+ BNE PFNDUN
+PFNDBR LDB ,X+
+ TSTB ; ; Is high bit of character in dictionary entry set?
+ BPL PFNDCH
+ ANDB #$7F ; Clear high bit from dictionary.
+ CMPB ,Y+ ; Compare "last" characters.
+ BEQ FOUND ; Matches even if dictionary actual length is shorter.
+PFNDLN LDX ,X++ ; Get previous link in vocabulary.
+ BNE PFNDLP ; Continue if link not=0
*
* not found :
-*
- CLRA ;
- CLRB ;
- JMP PUSHBA
-PFIND8 PSHS B ; ** emulating CBA:
- CMPA ,S+ ;
- BEQ PFIND2
-PFIND4 LDX PD
-PFIND9 LDB 0,X scan forward to end of this name
- LEAX 1,X ;
- BPL PFIND9
- BRA PFIND3
+ LEAU 2,U ; Return only false flag.
+ LDD #0
+ STD ,U
+ PULS Y,PC
+*
+PFNDCH CMPB ,Y+ ; Compare characters.
+ BEQ PFNDBR
+PFNDUN
+PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
+ 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 ;
+FOUND LEAX 4,X
+ STX 2,U
+ TFR A,B
+ CLRA
+ STD ,U
LDB #1
- JMP PUSHBA
+ PSHU A,B
+ PULS Y,PC
+*
+* 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
*
- PSHS A ;
- CLRA ;
- PSHS A ;
- LDB #1
- JMP PUSHBA
+* 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 2,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 ; For some reason, point after NUL.
+ 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 PSHU A,B ; Save offset to first after symbol (NUL)
+ PSHU A,B ; and count scanned.
+ 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 *+2
- 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
-ENCL2 LDA 0,X
- BEQ ENCL6
- PSHS B ; ** emulating CBA:
- CMPA ,S+ ; CHECK FOR DELIM
- BNE ENCL3
- LEAX 1,X ;
- INC N
- BRA ENCL2
-* found first character. Push FC
-ENCL3 LDA N found first char.
- PSHS A ;
- CLRA ;
- PSHS A ;
+* 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
-ENCL4 LDA 0,X
- BEQ ENCL7
- PSHS B ; ** emulating CBA:
- CMPA ,S+ ; ckech for delim.
- BEQ ENCL5
- LEAX 1,X ;
- INC N
- BRA ENCL4
-* found EW. Push it
-ENCL5 LDB N
- CLRA ;
- PSHS B ;
- PSHS A ;
-* advance and push NC
- INCB ;
- JMP PUSHBA
+* 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
-ENCL6 LDB N found NUL
- PSHS B ;
- PSHS A ;
- INCB ;
- BRA ENCL7+2
+* 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
-ENCL7 LDB N
- PSHS B ; save EW
- PSHS A ;
-ENCL8 LDB N save NC
- JMP PUSHBA
+* ENC0TR LDB N
+* PSHS B ; save EW
+* PSHS A ;
+* ENCL8 LDB N save NC
+* JMP PUSHBA
PAGE
*
* 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 *+2
- 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
+EMIT FDB *+NATWID
+ LBSR PEMIT ; PEMIT handles the stack.
+ 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 *+2
- JSR PKEY
- PSHS A ;
- CLRA ;
- PSHS A ;
- JMP NEXT
+KEY FDB *+NATWID
+ LBSR PKEY ; PKEY handles the stack.
+ 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 *+2
- JSR PQTER
- CLRB ;
- JMP PUSHBA stack the flag
+QTERM FDB *+NATWID
+ LBSR PQTER ; PQTER handles the stack.
+ 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 *+2
- JSR PCR
- JMP NEXT
+CR FDB *+NATWID
+ LBSR PCR ; PCR handles the stack.
+ RTS
+* 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 *+2 takes ( 43+47*count cycles )
- 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
+CMOVE FDB *+NATWID
+* One way: ; takes ( 37+17*count+9*(count/256) cycles )
+ PSHS Y ; #2~7 ; Gotta have our pointers.
+ PULU D,X,Y ; #2~11
+ PSHS A ; #2~6 ; Gotta have our pointers.
+ BRA CMOVLE ; #2~3
+CMOVLP
+ LDA ,Y+ ; #2~6
+ STA ,X+ ; #2~6
+CMOVLE
+ SUBB #1 ; #2~2
+ BCC CMOVLP ; #2~3
+ DEC ,S ; #2=6
+ BPL CMOVLP ; #2~3
+ PULS A,Y,PC ; #2~10
+* 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
+* Yet another way ; takes ( 37+29*count cycles )
+* PSHS Y ; #2~7
+* LDX 2,U ; #2~6
+* LDY 4,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 6,U ; #2~5
+* PULS Y,PC ; #2~9
+* Yet another way ; takes ( 44+24*odd+33*count/2 cycles )
+* PSHS Y ; #2~7
+* LDX 2,U ; #2~6
+* LDY 4,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 6,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 *+2
- BSR USTARS
- LEAS 1,S ;
- LEAS 1,S ;
- JMP PUSHBA
+USTAR FDB *+NATWID
+ LEAU -4,U
+ LDA 5,U ; least
+ LDB 7,U
+ MUL
+ STD 2,U
+ LDA 4,U ; most
+ LDB 6,U
+ MUL
+ STD ,U
+ LDD 5,U ; first inner (u2 lo, u1 hi)
+ MUL
+ ADDD 1,U
+ BCC USTAR3
+ INC ,U
+USTAR3 STD 1,U
+ LDA 4,U ; second inner (u2 hi)
+ LDB 7,U ; (u1 lo)
+ MUL
+ ADDD 1,U
+ BCC USTAR4
+ INC ,U
+USTAR4 STD 1,U
+ PULS D,X
+ STD ,U
+ STX 2,U
+ RTS
+* 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
+* 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.
+*
FCB $82
FCC 'U' ; 'U/'
FCB $AF
FDB USTAR-5
-USLASH FDB *+2
- 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
+USLASH FDB *+NATWID
+ LDA #17 ; bit ct
+ PSHS A
+ LDD 2,U ; dividend
+USLDIV CMPD ,U ; divisor
+ BHS USLSUB
+ ANDCC #~1 ; carry clear
+ BRA USLBIT
+USLSUB SUBD ,U
+ ORCC #1 ; quotient, (carry set)
+USLBIT ROL 5,U ; save it
+ ROL 4,U
+ DEC ,S ; more bits?
+ BEQ USLR
+ ROLB ; remainder
+ ROLA
+ BCC USLDIV
+ BRA USLSUB
+USLR LEAU 2,U
+ LDX 2,U
+ STD 2,U
+ STX ,U
+ PULS A,PC ; Avoiding a LEAS 1,S by discarding A.
+* 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 *+2
- PULS A ;
- PULS B ;
- TFR S,X ; TSX :
- ANDB 1,X
- ANDA 0,X
- JMP STABX
+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 *+2
- PULS A ;
- PULS B ;
- TFR S,X ; TSX :
- ORB 1,X
- ORA 0,X
- JMP STABX
+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 *+2
- PULS A ;
- PULS B ;
- TFR S,X ; TSX :
- EORB 1,X
- EORA 0,X
- JMP STABX
+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 *+2
- TFR S,X ; TSX :
- STX N scratch area
- LDX #N
- JMP GETX
+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 *+2
- LDX UP
- LDX XSPZER-UORIG,X
- TFR X,S ; TXS : watch it ! X and S are not equal.
- JMP NEXT
+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 *+2
- LDX RINIT initialize from rom constant
- STX RP
- JMP NEXT
+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 *+2
- 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
+SEMIS FDB *+NATWID
+ PULS D,X
+ TFR D,PC ; and discard X.
+* 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 *+2
- LDX RP
- LDA 2,X
- LDB 3,X
- STA 4,X
- STB 5,X
- JMP NEXT
+LEAVE FDB *+NATWID
+ LDD 2,S ; Dodge the return address.
+ STD 4,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 *+2
- LDX RP
- LEAX -1,X ;
- LEAX -1,X ;
- STX RP
- PULS A ;
- PULS B ;
- STA 2,X
- STB 3,X
- JMP NEXT
+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 *+2
- LDX RP
- LDA 2,X
- LDB 3,X
- LEAX 1,X ;
- LEAX 1,X ;
- STX RP
- JMP PUSHBA
+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 *+2
- LDX RP
- LEAX 1,X ;
- LEAX 1,X ;
- JMP GETX
+R FDB I+NATWID
+
+* LDX RP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* JMP GETX
*
* ######>> screen 28 <<
* ======>> 31 <<
+* ( 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 R-4
-ZEQU FDB *+2
- TFR S,X ; TSX :
- CLRA ;
- CLRB ;
- LDX 0,X
- BNE ZEQU2
- INCB ;
-ZEQU2 TFR S,X ; TSX :
- JMP STABX
+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 *+2
- 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
+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 *+2
- PULS A ;
- PULS B ;
- TFR S,X ; TSX :
- ADDB 1,X
- ADCA 0,X
- JMP STABX
+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 *+2
- 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
+DPLUS FDB *+NATWID
+ LDD 6,U
+ ADDD 2,U
+ STD 6,U
+ LDD 4,U
+ ADCB 1,U
+ ADCA ,U
+ LEAU 4,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 *+2
- TFR S,X ; TSX :
- NEG 1,X
- BCC MINUS2
- NEG 0,X
- BRA MINUS3
-MINUS2 COM 0,X
-MINUS3 JMP NEXT
+MINUS FDB *+NATWID
+ LDD #0 ; #3~3
+ SUBD ,U ; #2~5
+ STD ,U ; #2~5
+ RTS ; #1~5 = #8~18
+* 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 *+2
- 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
+DMINUS FDB *+NATWID
+ LDD #0 ; #3~3
+ SUBD 2,U ; #2~7
+ STD 2,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 *+2
- TFR S,X ; TSX :
- LDA 2,X
- LDB 3,X
- JMP PUSHBA
+OVER FDB *+NATWID
+ LDD 2,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 *+2
- LEAS 1,S ;
- LEAS 1,S ;
- JMP NEXT
+DROP FDB *+NATWID
+ LEAU 2,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 *+2
- 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
+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 *+2
- PULS A ;
- PULS B ;
- PSHS B ;
- PSHS A ;
- JMP PUSHBA
+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 *+2
- 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
+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 DOCOL,OVER,CAT,XOR,SWAP,CSTORE
- FDB SEMIS
+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 *+2
- TFR S,X ; TSX :
- LDX 0,X get address
- LEAS 1,S ;
- LEAS 1,S ;
- JMP GETX
+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 *+2
- TFR S,X ; TSX :
- LDX 0,X
- CLRA ;
- LDB 0,X
- LEAS 1,S ;
- LEAS 1,S ;
- JMP PUSHBA
+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 *+2
- TFR S,X ; TSX :
- LDX 0,X get address
- LEAS 1,S ;
- LEAS 1,S ;
- JMP PULABX
+STORE FDB *+NATWID
+ LDD 2,U
+ STD [,U]
+ LEAU 4,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 *+2
- 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
+CSTORE FDB *+NATWID
+ LDB 3,U
+ STB [,U]
+ LEAU 4,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. Maybe later.
FCB $C1 : immediate
FCB $BA
FDB CSTORE-5
* nested words in the virtual machine:
* ( ;S is the equivalent un-nester )
-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
+* ( *** 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.
+ LEAX 2,X ; W still in X, bump to parameter field.
+ TFR X,Y ; Load the 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
*
* ######>> 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
-DOCON LDX W
- LDA 2,X
- LDB 3,X A & B now contain the constant
- JMP PUSHBA
+* ( --- n )
+* Characteristic of a CONSTANT.
+* A CONSTANT simply loads its value from its parameter field
+* and pushes it on the stack.
+DOCON LDD 2,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
*
* ======>> 50 <<
+* ( init --- )
+* { init VARIABLE name } typical input
+* CREATE a header and compile the initial value, init, using CONSTANT,
+* overwrite the characteristic to point to DOVAR.
FCB $88
FCC 'VARIABL' ; 'VARIABLE'
FCB $C5
FDB CON-11
VAR FDB DOCOL,CON,PSCODE
-DOVAR LDA W
- LDB W+1
- ADDB #2
- ADCA #0 A,B now contain the address of the variable
- JMP PUSHBA
+* ( --- 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 2,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
-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
+* ( --- 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
+ ADDD 2,X ; Add the offset to the per-user variable.
+ PSHU D
+ 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.
+*
+* 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
FDB 0000
*
* ======>> 53 <<
+* ( --- 1 )
FCB $81
FCB $B1 1
FDB ZERO-4
FDB 1
*
* ======>> 54 <<
+* ( --- 2 )
FCB $81
FCB $B2 2
FDB ONE-4
FDB 2
*
* ======>> 55 <<
+* ( --- 3 )
FCB $81
FCB $B3 3
FDB TWO-4
FDB 3
*
* ======>> 56 <<
+* ( --- SP )
+* ASCII SPACE character
FCB $82
FCC 'B' ; 'BL'
FCB $CC
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 MEMEND-528 (132 * NBLK)
+ 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 MEMEND
+ FDB BUFBAS+BUFSZ
+* FDB MEMEND
*
* ======>> 59 <<
+* ( --- sectorsize )
+* The size, in bytes, of a buffer.
FCB $85
FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
FCB $C6
FDB LIMIT-8
BBUF FDB DOCON
- FDB 128
+ FDB SECTSZ
+* 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 8
-* blocks/screen = 1024 / "B/BUF" = 8
+ FDB SCRSZ/SECTSZ
+* 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
*
* ######>> 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 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 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 XTIB-UORIG
*
* ======>> 65 <<
+* ( --- maxnamewidth )
+* This is the maximum width to which symbol names will be recorded.
FCB $85
FCC 'WIDT' ; 'WIDTH'
FCB $C8
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 XWARN-UORIG
*
* ======>> 67 <<
+* ( --- vadr )
+* Boundary for FORGET.
FCB $85
FCC 'FENC' ; 'FENCE'
FCB $C5
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
-DP FDB DOUSER
- FDB XDP-UORIG
+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.
FCB $88
FCC 'VOC-LIN' ; 'VOC-LINK'
FCB $CB
- FDB DP-5
+ 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 variable! ********
+* But the base system needs to have full 32 bit support, div and mul, etc.
FCB $83
FCC 'BL' ; 'BLK'
FCB $CB
FDB XBLK-UORIG
*
* ======>> 70 <<
+* ( --- vadr )
+* Input buffer offset/cursor.
FCB $82
FCC 'I' ; 'IN' : scan pointer for input line buffer
FCB $CE
FDB XIN-UORIG
*
* ======>> 71 <<
+* ( --- vadr )
+* Output buffer offset/cursor.
FCB $83
FCC 'OU' ; 'OUT'
FCB $D4
FDB XOUT-UORIG
*
* ======>> 72 <<
+* ( --- vadr )
+* Screen currently being edited, once we have an editor running.
FCB $83
FCC 'SC' ; 'SCR'
FCB $D2
* ######>> 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 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 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 XCURR-UORIG
*
* ======>> 76 <<
+* ( --- vadr )
+* Compiler/interpreter state.
FCB $85
FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
FCB $C5
FDB XSTATE-UORIG
*
* ======>> 77 <<
+* ( --- vadr )
+* Numeric conversion base.
FCB $84
FCC 'BAS' ; 'BASE' : number base for all input & output
FCB $C5
FDB XBASE-UORIG
*
* ======>> 78 <<
+* ( --- vadr )
+* Decimal point location for output.
FCB $83
FCC 'DP' ; 'DPL'
FCB $CC
FDB XDPL-UORIG
*
* ======>> 79 <<
+* ( --- vadr )
+* Field width for I/O formatting.
FCB $83
FCC 'FL' ; 'FLD'
FCB $C4
FDB XFLD-UORIG
*
* ======>> 80 <<
+* ( --- vadr )
+* Compiler stack mark for stack check.
FCB $83
FCC 'CS' ; 'CSP'
FCB $D0
FDB XCSP-UORIG
*
* ======>> 81 <<
+* ( --- vadr )
+* Editing cursor location.
FCB $82
FCC 'R' ; 'R#'
FCB $A3
FDB XRNUM-UORIG
*
* ======>> 82 <<
+* ( --- vadr )
+* Pointer to last HELD character in PAD.
FCB $83
FCC 'HL' ; 'HLD'
FCB $C4
FDB XHLD
*
* ======>> 82.5 <<== SPECIAL
+* ( --- vadr )
+* Line width of active terminal.
FCB $87
FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
FCB $D3
FDB XCOLUM-UORIG
*
* ######>> screen 38 <<
+** Could make an incrementer compiling word:
+** ( n --- )
+** { n INCREMENTER name } typical input
+** CREATE a header and compile the increment constant,
+** then overwrite the header with a call to DOINC.
+* FCB $84
+* FCC 'INCREMENTE' ; INCREMENTER'
+* FCB $D2
+* FDB COLUMS-9
+* INCR FDB DOCOL,CON,PSCODE
+** ( n --- ninc )
+** Characteristic of an INCREMENTER.
+* DOINC LDD ,U
+* ADDD 2,X ; Add the increment.
+* STD ,U
+* RTS
+*
* ======>> 83 <<
+* ( n --- n+1 )
FCB $82
FCC '1' ; '1+'
FCB $AB
FDB COLUMS-10
-ONEP FDB DOCOL,ONE,PLUS
- FDB SEMIS
+ONEP FDB *+NATWID
+ LDD ,U
+ ADDD #1
+ STD ,U
+ RTS
+* ONEP FDB DOCOL,ONE,PLUS
+* FDB SEMIS
*
* ======>> 84 <<
+* ( n --- n+2 )
FCB $82
FCC '2' ; '2+'
FCB $AB
FDB ONEP-5
-TWOP FDB DOCOL,TWO,PLUS
- FDB SEMIS
+TWOP FDB *+NATWID
+ LDD ,U
+ ADDD #2
+ STD ,U
+ RTS
+* TWOP FDB DOCOL,TWO,PLUS
+* FDB SEMIS
*
* ======>> 85 <<
FCB $84
FCC 'HER' ; 'HERE'
FCB $C5
FDB TWOP-5
-HERE FDB DOCOL,DP,AT
+HERE FDB DOCOL,DICTPT,AT
FDB SEMIS
*
* ======>> 86 <<
FCC 'ALLO' ; 'ALLOT'
FCB $D4
FDB HERE-7
-ALLOT FDB DOCOL,DP,PSTORE
+ALLOT FDB DOCOL,DICTPT,PSTORE
FDB SEMIS
*
* ======>> 87 <<
FDB SEMIS
*
* ======>> 89 <<
+* ( n1 n2 --- n1-n2 )
+* Subtract top two words.
FCB $81 ; -
FCB $AD
FDB CCOMM-5
-SUB FDB DOCOL,MINUS,PLUS
- FDB SEMIS
+SUB FDB *+NATWID
+ LDD 2,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 <<
FCB $81 =
FCB $81 <
FCB $BC
FDB EQUAL-4
-LESS FDB *+2
+LESS FDB *+NATWID
PULS A ;
PULS B ;
TFR S,X ; TSX :
FCB $C5
FDB DDUP-7
TRAV FDB DOCOL,SWAP
-TRAV2 FDB OVER,PLUS,CLITER
+TRAV2 FDB OVER,PLUS,LIT8
FCB $7F
FDB OVER,CAT,LESS,ZBRAN
FDB TRAV2-*
FCC 'LF' ; 'LFA'
FCB $C1
FDB LATEST-9
-LFA FDB DOCOL,CLITER
+LFA FDB DOCOL,LIT8
FCB 4
FDB SUB
FDB SEMIS
FCC 'NF' ; 'NFA'
FCB $C1
FDB CFA-6
-NFA FDB DOCOL,CLITER
+NFA FDB DOCOL,LIT8
FCB 5
FDB SUB,ONE,MINUS,TRAV
FDB SEMIS
FCC 'PF' ; 'PFA'
FCB $C1
FDB NFA-6
-PFA FDB DOCOL,ONE,TRAV,CLITER
+PFA FDB DOCOL,ONE,TRAV,LIT8
FCB 5
FDB PLUS
FDB SEMIS
FCC '?COM' ; '?COMP'
FCB $D0
FDB QERR-9
-QCOMP FDB DOCOL,STATE,AT,ZEQU,CLITER
+QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8
FCB $11
FDB QERR
FDB SEMIS
FCC '?EXE' ; '?EXEC'
FCB $C3
FDB QCOMP-8
-QEXEC FDB DOCOL,STATE,AT,CLITER
+QEXEC FDB DOCOL,STATE,AT,LIT8
FCB $12
FDB QERR
FDB SEMIS
FCC '?PAIR' ; '?PAIRS'
FCB $D3
FDB QEXEC-8
-QPAIRS FDB DOCOL,SUB,CLITER
+QPAIRS FDB DOCOL,SUB,LIT8
FCB $13
FDB QERR
FDB SEMIS
FCC '?CS' ; '?CSP'
FCB $D0
FDB QPAIRS-9
-QCSP FDB DOCOL,SPAT,CSP,AT,SUB,CLITER
+QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8
FCB $14
FDB QERR
FDB SEMIS
FCC '?LOADIN' ; '?LOADING'
FCB $C7
FDB QCSP-7
-QLOAD FDB DOCOL,BLK,AT,ZEQU,CLITER
+QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8
FCB $16
FDB QERR
FDB SEMIS
FCB $81 ]
FCB $DD
FDB LBRAK-4
-RBRAK FDB DOCOL,CLITER
+RBRAK FDB DOCOL,LIT8
FCB $C0
FDB STATE,STORE
FDB SEMIS
FCC 'SMUDG' ; 'SMUDGE'
FCB $C5
FDB RBRAK-4
-SMUDGE FDB DOCOL,LATEST,CLITER
+SMUDGE FDB DOCOL,LATEST,LIT8
FCB $20
FDB TOGGLE
FDB SEMIS
FCB $D8
FDB SMUDGE-9
HEX FDB DOCOL
- FDB CLITER
+ FDB LIT8
FCB 16
FDB BASE,STORE
FDB SEMIS
FCB $CC
FDB HEX-6
DEC FDB DOCOL
- FDB CLITER
+ FDB LIT8
FCB 10 note: hex "A"
FDB BASE,STORE
FDB SEMIS
FCB $A2
FDB PDOTQ-7
DOTQ FDB DOCOL
- FDB CLITER
+ FDB LIT8
FCB $22 ascii quote
FDB STATE,AT,ZBRAN
FDB DOTQ1-*
FCC '?STAC' ; '?STACK'
FCB $CB
FDB DOTQ-5
-QSTACK FDB DOCOL,CLITER
+QSTACK FDB DOCOL,LIT8
FCB $12
FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
FDB QERR
*
QSTAC2 FDB SPAT
* Here, we compare with a value at least 128
-* higher than dict. ptr. (DP)
- FDB HERE,CLITER
+* higher than dict. ptr. (DICTPT)
+ FDB HERE,LIT8
FCB $80
FDB PLUS,LESS,ZBRAN
FDB QSTAC3-*
* FCC 4,?FREE
* FCB $C5
* FDB QSTACK-9
-*QFREE FDB DOCOL,SPAT,HERE,CLITER
+*QFREE FDB DOCOL,SPAT,HERE,LIT8
* FCB $80
* FDB PLUS,LESS,TWO,QERR,SEMIS
*
FCB $D4
FDB QSTACK-9
EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO
-EXPEC2 FDB KEY,DUP,CLITER
+EXPEC2 FDB KEY,DUP,LIT8
FCB $0E
FDB PORIG,AT,EQUAL,ZBRAN
FDB EXPEC3-*
- FDB DROP,CLITER
+ FDB DROP,LIT8
FCB 8 ( backspace character to emit )
FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS
FDB TOR,SUB,BRAN
FDB EXPEC6-*
-EXPEC3 FDB DUP,CLITER
+EXPEC3 FDB DUP,LIT8
FCB $D ( carriage return )
FDB EQUAL,ZBRAN
FDB EXPEC4-*
FCC 'PA' ; 'PAD'
FCB $C4
FDB HOLD-7
-PAD FDB DOCOL,HERE,CLITER
+PAD FDB DOCOL,HERE,LIT8
FCB $44
FDB PLUS
FDB SEMIS
FDB BLK,AT,BLOCK,BRAN
FDB WORD3-*
WORD2 FDB TIB,AT
-WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,CLITER
+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
FCC 'NUMBE' ; 'NUMBER'
FCB $D2
FDB PNUMB-11
-NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,CLITER
+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-*
- FDB DUP,CAT,CLITER
+ FDB DUP,CAT,LIT8
FCC "."
FDB SUB,ZERO,QERR,ZERO,BRAN
FDB NUMB1-*
FCC 'ID' ; 'ID.'
FCB $AE
FDB ERROR-8
-IDDOT FDB DOCOL,PAD,CLITER
+IDDOT FDB DOCOL,PAD,LIT8
FCB 32
- FDB CLITER
+ FDB LIT8
FCB $5F ( underline )
FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
- FDB SWAP,CMOVE,PAD,COUNT,CLITER
+ FDB SWAP,CMOVE,PAD,COUNT,LIT8
FCB 31
FDB AND,TYPE,SPACE
FDB SEMIS
FCB 8
FCB 7 ( bel )
FCC "redef: "
- FDB NFA,IDDOT,CLITER
+ FDB NFA,IDDOT,LIT8
FCB 4
FDB MESS,SPACE
CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
- FDB ONEP,ALLOT,DUP,CLITER
+ FDB ONEP,ALLOT,DUP,LIT8
FCB $A0
- FDB TOGGLE,HERE,ONE,SUB,CLITER
+ FDB TOGGLE,HERE,ONE,SUB,LIT8
FCB $80
FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
FDB HERE,TWOP,COMMA
FCC 'IMMEDIAT' ; 'IMMEDIATE'
FCB $C5
FDB INTERP-12
-IMMED FDB DOCOL,LATEST,CLITER
+IMMED FDB DOCOL,LATEST,LIT8
FCB $40
FDB TOGGLE
FDB SEMIS
FCB $C1 immediate (
FCB $A8
FDB DEFIN-14
-PAREN FDB DOCOL,CLITER
+PAREN FDB DOCOL,LIT8
FCC ")"
FDB WORD
FDB SEMIS
FCC 'COL' ; 'COLD'
FCB $C4
FDB ABORT-8
-COLD FDB *+2
+COLD FDB *+NATWID
CENT LDS #REND-1 top of destination
LDX #ERAM top of stuff to move
COLD2 LEAX -1,X ;
LDX VOCINT
STX XVOCL
LDX DPINIT
- STX XDP
+ STX XDICTP
LDX FENCIN
STX XFENCE
FCB $81 ; *
FCB $AA
FDB STOD-7
-STAR FDB *+2
- JSR USTARS
- LEAS 1,S ;
- LEAS 1,S ;
- JMP NEXT
+STAR FDB *+NATWID
+ JSR [USTAR]
+ LEAU 2,U ;
+ RTS
+* JSR USTARS
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP NEXT
*
* ======>> 160 <<
FCB $84
FCC '+BU' ; '+BUF'
FCB $C6
FDB PREV-7
-PBUF FDB DOCOL,CLITER
+PBUF FDB DOCOL,LIT8
FCB $84
FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
FDB PBUF2-*
FCC '(LINE' ; '(LINE)'
FCB $A9
FDB BLOCK-8
-PLINE FDB DOCOL,TOR,CLITER
+PLINE FDB DOCOL,TOR,LIT8
FCB $40
- FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,CLITER
+ FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
FCB $40
FDB SEMIS
*
FDB MESS3-*
FDB DDUP,ZBRAN
FDB MESS3-*
- FDB CLITER
+ FDB LIT8
FCB 4
FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
FDB MESS4-*
* called by words 13 through 16 in the dictionary.
*
* ======>> 182 << code for EMIT
-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
+* output using rom CHROUT: redirectable to printer
+PEMIT PULU D
+PEMITW TFR B,A ; Coco ROM wants it in A.
+ PSHS Y,U,DP ; Save everything important!
+ CLRB
+ TFR B,DP ; Give the ROM it's 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
-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
+* wait for key from POLCAT
+PKEY PSHS Y,U,DP
+ LDA #$CF ; a cursor of sorts
+ CLRB
+ TFR B,DP
+ SETDP 0
+ LDX <$88 ; location
+ LDB ,X ; save glyph
+ STA ,X
+PKEYLP JSR [$A000]
+ BEQ PKEYLP
+ STB ,X ; restore
+PKEYR CLRB ; for the break flag
+ CMPA #3 ; break key
+ BNE PKEYGT
+ COMB ; for the break flag
+PKEYGT EXG A,B
+ PSHU D
+ PULS Y,U,DP,PC
+ SETDP IUPDP ******** Check this when I get here again. *********
+* 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
-PQTER LDA ACIAC Test for 'break' condition
- ANDA #$11 mask framing error bit and
+* check break key using POLCAT
+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
+* BEQ PQTER2
+* LDA ACIAD clear input buffer
+* LDA #01
+* PQTER2 RTS
PAGE
*
* ======>> 185 << code for CR
-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
+* For Coco just output a CR.
+PCR LDB #$0D
+ BRA PEMITW
+* 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
FCC '?DIS' ; '?DISC'
FCB $C3
FDB ARROW-6
-QDISC FDB *+2
+QDISC FDB *+NATWID
JMP NEXT
*
* ######>> screen 67 <<
FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
FCB $C5
FDB QDISC-8
-BWRITE FDB *+2
+BWRITE FDB *+NATWID
JMP NEXT
*
* ######>> screen 68 <<
FCC 'BLOCK-REA' ; 'BLOCK-READ'
FCB $C4
FDB BWRITE-14
-BREAD FDB *+2
+BREAD FDB *+NATWID
JMP NEXT
*
*The next 3 words are written to create a substitute for disc
FCC 'FORGE' ; 'FORGET'
FCB $D4
FDB TICK-4
-FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,CLITER
+FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
FCB $18
- FDB QERR,TICK,DUP,FENCE,AT,LESS,CLITER
+ FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT8
FCB $15
- FDB QERR,DUP,ZERO,PORIG,GREAT,CLITER
+ FDB QERR,DUP,ZERO,PORIG,GREAT,LIT8
FCB $15
- FDB QERR,DUP,NFA,DP,STORE,LFA,AT,CONTXT,AT,STORE
+ FDB QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
FDB SEMIS
*
* ######>> screen 73 <<
FDB EDIGS-5
SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
FDB SIGN2-*
- FDB CLITER
+ FDB LIT8
FCC "-"
FDB HOLD
SIGN2 FDB SEMIS
FCB $81 #
FCB $A3
FDB SIGN-7
-DIG FDB DOCOL,BASE,AT,MSMOD,ROT,CLITER
+DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
FCB 9
FDB OVER,LESS,ZBRAN
FDB DIG2-*
- FDB CLITER
+ FDB LIT8
FCB 7
FDB PLUS
-DIG2 FDB CLITER
+DIG2 FDB LIT8
FCC "0" ascii zero
FDB PLUS,HOLD
FDB SEMIS
LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
FCB 6
FCC "SCR # "
- FDB DOT,CLITER
+ FDB DOT,LIT8
FCB $10
FDB ZERO,XDO
LIST2 FDB CR,I,THREE
FDB LEAVE
TRIAD3 FDB XLOOP
FDB TRIAD2-*
- FDB CR,CLITER
+ FDB CR,LIT8
FCB $0F
FDB MESS,CR
FDB SEMIS
FCC 'VLIS' ; 'VLIST'
FCB $D4
FDB TRIAD-8
-VLIST FDB DOCOL,CLITER
+VLIST FDB DOCOL,LIT8
FCB $80
FDB OUT,STORE,CONTXT,AT,AT
-VLIST1 FDB OUT,AT,COLUMS,AT,CLITER
+VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
FCB 32
FDB SUB,GREAT,ZBRAN
FDB VLIST2-*
NOOP FDB 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:
+*
+ FCB $C5 immediate
+ FCC 'FORT' ; 'FORTH'
+ FCB $C8
+ FDB NOOP-7
+FORTH FDB DODOES,DOVOC,$81A0,TASK-7
+ FDB 0
+*
+ FCC "(C) Forth Interest Group, 1979"
+
+ FCB $84
+ FCC 'TAS' ; 'TASK'
+ FCB $CB
+ FDB FORTH-8
+TASK FDB DOCOL,SEMIS
+*
+REND EQU * ( first empty location in dictionary )
+
OSDN Git Service
