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}
-* 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.
+* 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.
-* === by Dave Lion,
+* 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,
* === 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
-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
+*
+* 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
-* 3210 LO,MEMEND
-* 320F
+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
-* 3000 FIRST
-* >>>>>> memory from here up must be RAM <<<<<<
+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
*
-* 27FF
-* 6k of romable "FORTH" <== IP ABORT
-* <== W
-* the VIRTUAL FORTH MACHINE
+ PAGE
+*
+* Don't want one return too many to destroy the disc buffers.
+RPBUMP EQU 4*NATWID
+*
+* 32D8|71D8 <== RP RINIT
*
-* 1004 <<< WARM START ENTRY >>>
-* 1000 <<< COLD START ENTRY >>>
+IRP EQU BUFBAS-RPBUMP
+* RETURN STACK
+RSTK16 EQU $50*NATWID ; 80 max levels nesting calls
+RSTK32 EQU $90*NATWID ; 144 max
+RSTKSZ EQU RSTK32
*
-* >>>>>> memory from here down must be RAM <<<<<<
-* FFE RETURN STACK base <== RP RINIT
+* 3248|70B8
*
-* FB4
+SFTBND EQU IRP-RSTKSZ ; (false boundary between TIB and return stack)
* INPUT LINE BUFFER
-* holds up to 132 characters
+* holds up to TIBSZ 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
+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
*
-* 183 end of ram-dictionary. <== DP DPINIT
+* >>>>>>--------Two words to start RAMmable dictionary--------<<<<<<
+*
+* (2B00)
+* ???? 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.
+*
+* >>>>>> memory from here up must be in RAM area <<<<<<
*
-* 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
+* ????
+* 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 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
-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
+* 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
+ 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 <<
*
** C O L D E N T R Y **
***************************
ORIG NOP
- JMP CENT
+* JMP CENT
+ LBSR CENT
***************************
** W A R M E N T R Y **
***************************
NOP
- JMP WENT warm-start code, keeps current dictionary intact
+* JMP WENT warm-start code, keeps current dictionary intact
+ LBSR 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
+* BACKSP FDB $7F backspace character for editing
+BACKSP FDB $08 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
-VOCINT FDB FORTH+8
-COLINT FDB 132 initial terminal carriage width
+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 <<
-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
+* 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
- NOP
+* 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
- 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
+ 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 <<
-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
+*
+* ( 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 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 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
-*
+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 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 *+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 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
+* 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 NATWID,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 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 format in the dictionary is:
+* The word definition format in the dictionary:
*
-* char-count + $80 lowest address
-* char 1
+* (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
-* 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.
+* 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 *+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 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 :
*
- 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
+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 ;
- CLRA ;
- PSHS A ;
- LDB #1
- JMP PUSHBA
+* 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 *+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
+ 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 *+2
- JSR PKEY
- PSHS A ;
- CLRA ;
- PSHS A ;
- JMP NEXT
+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 *+2
- JSR PQTER
- CLRB ;
- JMP PUSHBA stack the flag
+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 *+2
- JSR PCR
- JMP NEXT
+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 *+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
+* 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 *+2
- BSR USTARS
- LEAS 1,S ;
- LEAS 1,S ;
- JMP PUSHBA
+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
+* 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 *+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 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 *+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,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 *+2
- LDX RP
- LDA 2,X
- LDB 3,X
- STA 4,X
- STB 5,X
- JMP NEXT
+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 *+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 )
+* 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 R-4
-ZEQU FDB *+2
- TFR S,X ; TSX :
- CLRA ;
- CLRB ;
- LDX 0,X
- BNE ZEQU2
- INCB ;
-ZEQU2 TFR S,X ; TSX :
- JMP STABX
+ 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 *+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 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 *+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
+*
+* 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 *+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 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 *+2
- TFR S,X ; TSX :
- LDA 2,X
- LDB 3,X
- JMP PUSHBA
+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 *+2
- LEAS 1,S ;
- LEAS 1,S ;
- JMP NEXT
+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 *+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 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 *+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 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
* 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.
+ 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
*
* ######>> 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 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 CON-11
+ FDB NATP-7
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 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
-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
+* 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
FDB 0000
*
* ======>> 53 <<
+* ( --- 1 )
FCB $81
FCB $B1 1
FDB ZERO-4
ONE FDB DOCON
- FDB 1
+ONEV FDB 1
*
* ======>> 54 <<
+* ( --- 2 )
FCB $81
FCB $B2 2
FDB ONE-4
TWO FDB DOCON
- FDB 2
+TWOV 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
+* 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 LIMIT-8
+ FDB BCTL-8
BBUF FDB DOCON
- FDB 128
+ 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 8
-* blocks/screen = 1024 / "B/BUF" = 8
+ 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
*
* ######>> 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.
+* Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
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 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 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 <<
+**
+** 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,DP,AT
+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,DP,PSTORE
+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,TWO,ALLOT
+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 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 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
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 *+2
- PULS A ;
- PULS B ;
- TFR S,X ; TSX :
- CMPA 0,X
- LEAS 1,S ;
- BGT LESST
- BNE LESSF
- CMPB 1,X
- BHI LESST
-LESSF CLRB ;
- BRA LESSX
-LESST LDB #1
-LESSX CLRA ;
- LEAS 1,S ;
- JMP PUSHBA
+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
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 DOCOL,TOR,SWAP,FROMR,SWAP
- FDB SEMIS
+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 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 DOCOL,OVER,OVER,GREAT,ZBRAN
- FDB MIN2-*
- FDB SWAP
-MIN2 FDB DROP
- FDB SEMIS
+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 DOCOL,OVER,OVER,LESS,ZBRAN
- FDB MAX2-*
- FDB SWAP
-MAX2 FDB DROP
- FDB SEMIS
+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 DOCOL,DUP,ZBRAN
- FDB DDUP2-*
- FDB DUP
-DDUP2 FDB SEMIS
+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 DDUP-7
-TRAV FDB DOCOL,SWAP
-TRAV2 FDB OVER,PLUS,CLITER
- FCB $7F
- FDB OVER,CAT,LESS,ZBRAN
- FDB TRAV2-*
- FDB SWAP,DROP
- FDB SEMIS
+ 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,CLITER
- FCB 4
+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,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,CLITER
- FCB 5
+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,CLITER
- FCB 5
+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 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-*
+ FDB QERR2-*-NATWID
FDB ERROR,BRAN
- FDB QERR3-*
+ 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,CLITER
+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,CLITER
+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,CLITER
+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,CLITER
+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,CLITER
+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,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
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,CLITER
- FCB $C0
+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,CLITER
- FCB $20
+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 CLITER
- FCB 16
+ 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 CLITER
- FCB 10 note: hex "A"
+ 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,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
*
* ######>> 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 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,TWOP,LATEST,PFA,STORE
+DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+ FDB LATEST,PFA,STORE
FDB PSCODE
-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
+*
+* ( --- 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 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-*
+ FDB TYPE3-*-NATWID
FDB OVER,PLUS,SWAP,XDO
TYPE2 FDB I,CAT,EMIT,XLOOP
- FDB TYPE2-*
+ FDB TYPE2-*-NATWID
FDB BRAN
- FDB TYPE4-*
+ 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
DTRAIL FDB DOCOL,DUP,ZERO,XDO
DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
FDB SUB,ZBRAN
- FDB DTRAL3-*
+ FDB DTRAL3-*-NATWID
FDB LEAVE,BRAN
- FDB DTRAL4-*
+ FDB DTRAL4-*-NATWID
DTRAL3 FDB ONE,SUB
DTRAL4 FDB XLOOP
- FDB DTRAL2-*
+ 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,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 CLITER
+ FDB LIT8
FCB $22 ascii quote
FDB STATE,AT,ZBRAN
- FDB DOTQ1-*
+ FDB DOTQ1-*-NATWID
FDB COMPIL,PDOTQ,WORD
FDB HERE,CAT,ONEP,ALLOT,BRAN
- FDB DOTQ2-*
+ 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,CLITER
- FCB $12
- FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
+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. (DP)
- FDB HERE,CLITER
- FCB $80
+* 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-*
- FDB TWO
+ FDB QSTAC3-*-NATWID
+ FDB TWO ; NOT the NATWID constant!
FDB QERR
* prints 'full stack'
*
* 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
+* 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
-EXPEC2 FDB KEY,DUP,CLITER
- FCB $0E
- FDB PORIG,AT,EQUAL,ZBRAN
- FDB EXPEC3-*
- FDB DROP,CLITER
+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
+ FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
FDB TOR,SUB,BRAN
- FDB EXPEC6-*
-EXPEC3 FDB DUP,CLITER
+ FDB EXPEC6-*-NATWID
+EXPEC3 FDB DUP,LIT8
FCB $D ( carriage return )
FDB EQUAL,ZBRAN
- FDB EXPEC4-*
- FDB LEAVE,DROP,BL,ZERO,BRAN
- FDB EXPEC5-*
+ 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-*
+ FDB EXPEC2-*-NATWID
FDB DROP
FDB SEMIS
*
* ======>> 129 <<
+* ( --- )
+* EXPECT 128 (TWID) characters to TIB.
FCB $85
FCC 'QUER' ; 'QUERY'
FCB $D9
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-*
+ 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-*
+ FDB NULL1-*-NATWID
FDB QEXEC,FROMR,DROP
NULL1 FDB BRAN
- FDB NULL3-*
+ 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 SEMIS
*
* ======>> 134 <<
+* ( adr n --- )
+* Fill n bytes with 0.
FCB $85
FCC 'ERAS' ; 'ERASE'
FCB $C5
FDB SEMIS
*
* ======>> 135 <<
+* ( adr n --- )
+* Fill n bytes with ASCII SPACE.
FCB $86
FCC 'BLANK' ; 'BLANKS'
FCB $D3
FDB SEMIS
*
* ======>> 136 <<
+* ( c --- )
+* Format a character at the left of the HLD output buffer.
FCB $84
FCC 'HOL' ; 'HOLD'
FCB $C4
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,CLITER
+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-*
+ FDB WORD2-*-NATWID
FDB BLK,AT,BLOCK,BRAN
- FDB WORD3-*
+ FDB WORD3-*-NATWID
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
*
* ######>> 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-*
+ FDB PNUMB4-*-NATWID
FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
- FDB PNUMB3-*
+ FDB PNUMB3-*-NATWID
FDB ONE,DPL,PSTORE
PNUMB3 FDB FROMR,BRAN
- FDB PNUMB2-*
+ 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,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 NUMB2-*-NATWID
+ FDB DUP,CAT,LIT8
FCC "."
FDB SUB,ZERO,QERR,ZERO,BRAN
- FDB NUMB1-*
+ FDB NUMB1-*-NATWID
NUMB2 FDB DROP,FROMR,ZBRAN
- FDB NUMB3-*
+ 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-*
+ 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
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
-* note: WARNING is -1 to abort, 0 to print error #
+ FDB ERROR2-*-NATWID
+* note: WARNING is
+* -1 to abort,
+* 0 to print error #
* and 1 to print error message from disc
- FDB ERROR2-*
FDB PABORT
ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
FCB 4,7 ( bell )
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 ERROR-8
-IDDOT FDB DOCOL,PAD,CLITER
+ FDB IDFLAT-9
+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
+ 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-*
+ FDB CREAT2-*-NATWID
FDB DROP,PDOTQ
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
- FCB $A0
- FDB TOGGLE,HERE,ONE,SUB,CLITER
+ 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,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 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-*
+ 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-*
- FDB SWAP,LITER,LITER
+ 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-*
+ FDB INTER5-*-NATWID
FDB STATE,AT,LESS
FDB ZBRAN
- FDB INTER3-*
+ FDB INTER3-*-NATWID
FDB CFA,COMMA,BRAN
- FDB INTER4-*
+ FDB INTER4-*-NATWID
INTER3 FDB CFA,EXEC
INTER4 FDB BRAN
- FDB INTER7-*
+ FDB INTER7-*-NATWID
INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
- FDB INTER6-*
+ FDB INTER6-*-NATWID
FDB DLITER,BRAN
- FDB INTER7-*
+ FDB INTER7-*-NATWID
INTER6 FDB DROP,LITER
INTER7 FDB QSTACK,BRAN
- FDB INTER2-*
+ 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,CLITER
- FCB $40
+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 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 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,CLITER
+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
* then repeats :
QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
FDB ZBRAN
- FDB QUIT3-*
+ FDB QUIT3-*-NATWID
FDB PDOTQ
FCB 3
FCC ' OK' ; ' OK'
QUIT3 FDB BRAN
- FDB QUIT2-*
+ 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 8
- FCC "Forth-68"
+ FCB 10
+ FCC "Forth-6809"
FDB FORTH,DEFIN
FDB QUIT
* FDB SEMIS never executed
FCC 'COL' ; 'COLD'
FCB $C4
FDB ABORT-8
-COLD FDB *+2
-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
+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
-*
- LDS #XFENCE-1 put stack at a safe place for now
- LDX COLINT
- STX XCOLUM
- LDX DELINT
- STX XDELAY
- LDX VOCINT
- STX XVOCL
- LDX DPINIT
- STX XDP
- LDX FENCIN
- STX XFENCE
-
-
-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
+* 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!
*
- LDS SINIT
- LDX UPINIT
- STX UP init user ram pointer
- LDX #ABORT
- STX IP
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 TRLIM clear trace mode
+ 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
- JMP RPSTOR+2 start the virtual machine running !
+* 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 :
-* at address $140:
-*
-RAM FDB $3000,$3000,0,0
-
+* (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
+ FDB NOOP-7 ; Note that this does not link to COLD!
RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
FDB 0
- FCC "(C) Forth Interest Group, 1979"
+ 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 FCC "David Lion"
+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
+ 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 *+2
- JSR USTARS
- LEAS 1,S ;
- LEAS 1,S ;
- JMP NEXT
+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 SEMIS
*
* ======>> 161 <<
+* ( dividend divisor --- quotient )
+* Signed word divide without remainder.
+* Except *BUG* it isn't signed.
FCB $81 ; /
FCB $AF
FDB SLMOD-7
FDB SEMIS
*
* ======>> 162 <<
+* ( dividend divisor --- remainder )
+* Remainder function, result takes sign of dividend.
FCB $83
FCC 'MO' ; 'MOD'
FCB $C4
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 SEMIS
*
* ======>> 164 <<
+* ( multiplier multiplicand divisor --- quotient )
+* */MOD without remainder.
FCB $82
FCC '*' ; '*/'
FCB $AF
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 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-*
+ 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-*
+ FDB DABS2-*-NATWID
FDB DMINUS
DABS2 FDB SEMIS
*
* ######>> screen 58 <<
-* Disc primatives :
+* 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
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
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,CLITER
- FCB $84
- FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
- FDB PBUF2-*
+* 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 PBUF-7
-UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
+ 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 UPDATE-9
+ 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 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
+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-*
+ FDB BUFFR2-*-NATWID
FDB USE,STORE,R,AT,ZLESS
FDB ZBRAN
- FDB BUFFR3-*
- FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
-BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
+ 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-*
+ FDB BLOCK5-*-NATWID
BLOCK3 FDB PBUF,ZEQU,ZBRAN
- FDB BLOCK4-*
- FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
+ 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-*
+ FDB BLOCK3-*-NATWID
FDB DUP,PREV,STORE
-BLOCK5 FDB FROMR,DROP,TWOP
+* 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,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
*
* ======>> 178 <<
+* ( line screen --- )
+* Print the line of the screen as found by (LINE), suppress trailing BLANKS.
FCB $85
FCC '.LIN' ; '.LINE'
FCB $C5
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-*
+ FDB MESS3-*-NATWID
FDB DDUP,ZBRAN
- FDB MESS3-*
- FDB CLITER
+ FDB MESS3-*-NATWID
+ FDB LIT8
FCB 4
FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
- FDB MESS4-*
+ FDB MESS4-*-NATWID
MESS3 FDB PDOTQ
FCB 6
FCC 'err # ' ; 'err # '
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 SEMIS
*
* ======>> 181 <<
+* ( --- ) P
+* Continue interpreting source code on the next screen.
FCB $C3
FCC '--' ; '-->'
FCB $BE
* 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
+* ( --- ) 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
-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
+* ( --- ) 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
-PQTER LDA ACIAC Test for 'break' condition
- ANDA #$11 mask framing error bit and
+* ( --- 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
+* 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
+* ( --- ) 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 <<
- FCB $85
+* ( ??? )
+* 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 *+2
+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 *+2
+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 *+2
+BREAD FDB *+NATWID
JMP NEXT
*
*The next 3 words are written to create a substitute for disc
-* mass memory,located between $3210 & $3FFF in ram.
+* mass memory,located between MASSLO & MASSHI in ram --
+* ($3210 and $3fff in the 6800 model).
* ======>> 190.1 <<
FCB $82
FCC 'L' ; 'LO'
FCB $C9
FDB LO-5
HI FDB DOCON
- FDB MEMTOP ( $3FFF in this version )
+ 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-*
+ FDB RW2-*-NATWID
FDB PDOTQ
FCB 8
FCC ' Range ?' ; ' Range ?'
FDB QUIT
RW2 FDB FROMR,ZBRAN
- FDB RW3-*
+ 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
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,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 <<
* ======>> 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,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
+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
- FDB OVER,SUB,SWAP,STORE
+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 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
+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
+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
+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
+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 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
+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
- FDB TWO,SUB,ENDIF
+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
+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
+ 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
+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-*
+ FDB SPACE3-*-NATWID
FDB ZERO,XDO
SPACE2 FDB SPACE,XLOOP
- FDB SPACE2-*
+ 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 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 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-*
- FDB CLITER
+ 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,CLITER
+DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
FCB 9
FDB OVER,LESS,ZBRAN
- FDB DIG2-*
- FDB CLITER
+ FDB DIG2-*-NATWID
+ FDB LIT8
FCB 7
FDB PLUS
-DIG2 FDB CLITER
+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-*
+ 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 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 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 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
FDB SEMIS
*
* ======>> 218 <<
+* ( adr --- )
+* Print signed word at adr, per DOT.
FCB $81 ?
FCB $BF
FDB DOT-4
*
* ######>> 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
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 DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
- FDB LIST2-*
+ 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
INDEX2 FDB CR,I,THREE
FDB DOTR,SPACE,ZERO,I,DLINE
FDB QTERM,ZBRAN
- FDB INDEX3-*
+ FDB INDEX3-*-NATWID
FDB LEAVE
INDEX3 FDB XLOOP
- FDB INDEX2-*
+ 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 THREE,OVER,PLUS,SWAP,XDO
TRIAD2 FDB CR,I
FDB LIST,QTERM,ZBRAN
- FDB TRIAD3-*
+ FDB TRIAD3-*-NATWID
FDB LEAVE
TRIAD3 FDB XLOOP
- FDB TRIAD2-*
- FDB CR,CLITER
+ 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,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-*
+ 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-*
+ 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 VLIST-8
-NOOP FDB NEXT a useful no-op
+ 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
OSDN Git Service
