--- /dev/null
+I think the current branch is auto-hand-optimized.
+
+I currently think the path I took to get here was sort of as follows:
+
+1: hand-translated
+(fig-forth_6809.asm -- an attempt to simply re-write with help)
+
+2: search-and-replace
+(fig6800to6809dumb.asm -- a least-work attempt, probably automatic)
+(socialize6809.pl -- a script to convert to more modern syntax)
+
+3: auto
+(6800to6809.pl -- incomplete automatic translation script)
+(figd6809.dsk -- color computer disk image used in testing and debugging)
+
+4: auto-hand-optimized-offline -- see NEXT loop for clues
+(fig-forth-auto6809.asm -- script output)
+(fig-forth-auto6809halfopt.asm -- replacing sequences with single instructions)
+(fig-forth-auto6809opt.asm -- native registers in use, parameter stack is U)
+
+5: auto-hand-optimized-detour (lopped branch)
+(figao.asm -- Trying to mix explicit inner loop with subroutine inner loop.)
+
+6: auto-hand-optimized (current, JMP and JSR proceeding in parallel, in suspended animation)
+fig-forth-auto6809.asm -> fig-forth-6809_jmp.asm -- Explicit NEXT loop, requires JMP/LBRA to NEXT
+fig-forth-auto6809opt.asm -> fig-forth-6809_ret -- subroutine NEXT, RET comes back to NEXT
+
+The files from the first three steps don't seem to be in my junkpiles. The files here are actually what existed about steps 3 to 5.
+
+master has not yet been merged with the current branch, in no small part because I kept getting interrupted in the processes and am not complete confident what happened when.
+
+The source files of most interest are fig-forth-6809_jmp.asm and fig-forth-6809_ret.asm.
+
+fig-forth-auto6809.asm was renamed fig-forth-6809_jmp.asm, because definitions return to the inner interpreter via JMP NEXT (or BRA/LBRA NEXT).
+
+fig-forth-auto6809opt.asm was renamed fig-forth-6809_ret.asm, because defnitions return to the inner interpreter via the RET instruction, allowing some leaf definitions to operate as simple subroutines.
+
+Either is a (presently buggy) implementation of a fig Forth kernel, which should assemble to function on the TRS-80/Tandy Color Computer.
--- /dev/null
+imgtool dir coco_jvc_rsdos figauto6809opt.dsk
+imgtool dir coco_jvc_rsdos workfig.dsk
+
+imgtool del coco_jvc_rsdos workfig.dsk FIG.BIN
+
+[imgtool put coco_jvc_rsdos figauto6809opt.dsk figao09.bin FIGAO09.BIN]
+imgtool put coco_jvc_rsdos workfig.dsk a.out FIG.BIN
+
+
+../../lwtools-4.14/lwasm/lwasm --list=fig-forth-auto6809opt.list fig-forth-auto6809opt.asm
+../../lwtools-4.14/lwasm/lwasm --list=fig-forth-auto6809.list fig-forth-auto6809.asm
+[../lwtools-4.14/lwasm/lwasm --list=figao.list figao.asm]
+
+for name in bif-6809lw/*.ASM ; do echo $name :\\n ; cat $name | tr '\r' '\n' | grep "BACK" ; done
+
+
+xroar-0.34.7/src/xroar -machine coco2bus -bas roms/Color\ Basic\ v1.3\ \(1982\)\(Tandy\).rom -extbas roms/Extended\ Colour\ Basic\ v1.0\ \(1981\)\(Tandy\)/coco.rom -cart rsdos -cart-rom roms/Color\ Computer\ Controller\ \(1982\)\ \(26-3022\).rom -keymap us -kbd-translate
+
+
+LOADM "FIG.BIN"
+LOADM"FIG
+EXEC &H1200
+
+
+hex
+
+: bemit dup bl < over 7f < 0= or
+if drop 2e endif
+emit ;
+
+: x.r base @ >r hex .r r> base ! ;
+
+
+: bline
+dup 4 + over do
+i c@ 3 x.r loop
+space space
+dup 4 + swap do
+i c@ bemit loop ;
+
+: bdump cr
+do i 4 x.r 3a emit space
+i bline cr 4 +loop ;
+
--- /dev/null
+ OPT PRT
+
+* fig-FORTH FOR 6809
+* ASSEMBLY SOURCE LISTING
+
+* RELEASE 0
+* JAN-FEB 2019
+* WITH COMPILER SECURITY
+* AND VARIABLE LENGTH NAMES
+* Returning to non-RTS mode
+*
+* Adapted by Joel Matthew Rees
+* from fig-FORTH for 6800 by Dave Lion, et. al.
+
+* This free/libre/open source publication is provided
+* through the courtesy of:
+* FORTH
+* INTEREST
+* GROUP
+* fig
+* and other interested parties.
+
+* Ancient address:
+* P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
+* URL: http://www.forth.org
+* Further distribution must include this notice.
+ PAGE
+ NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
+ OPT NOG,PAG
+* filename fig-forth-auto6809opt.asm
+* === FORTH-6809 {date} {time}
+
+
+* Permission is hereby granted, free of charge, to any person obtaining a copy
+* of this software and associated documentation files (the "Software"), to deal
+* in the Software without restriction, including without limitation the rights
+* to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+* copies of the Software, and to permit persons to whom the Software is
+* furnished to do so, subject to the following conditions:
+*
+* The above copyright notice and this permission notice shall be included in
+* all copies or substantial portions of the Software.
+
+* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+* THE SOFTWARE.
+*
+* "Associated documentation" for this declaration of license
+* shall be interpreted to include only the comments in this file,
+* or, if the code is split into multiple files,
+* all files containing the complete source.
+*
+* This is the MIT model license, as published by the Open Source Consortium,
+* with associated documentation defined.
+* It was chosen to reflect the spirit of the original
+* terms of use, which used archaic legal terminology.
+*
+
+* Authors of the 6800 model:
+* === Primary: Dave Lion,
+* === with help from
+* === Bob Smith,
+* === LaFarr Stuart,
+* === The Forth Interest Group
+* === PO Box 1105
+* === San Carlos, CA 94070
+* === and
+* === Unbounded Computing
+* === 1134-K Aster Ave.
+* === Sunnyvale, CA 94086
+*
+NATWID EQU 2 ; bytes per natural integer/pointer
+* The original version was developed on an AMI EVK 300 PROTO
+* system using an ACIA for the I/O.
+* This version is developed targeting the Tandy Color Computer.
+
+* All terminal 1/0
+* is done in three subroutines:
+* PEMIT ( word # 182 )
+* PKEY ( 183 )
+* PQTERM ( 184 )
+*
+* The FORTH words for disc related I/O follow the model
+* of the FORTH Interest Group, but have not yet been
+* tested using a real disc.
+*
+* Addresses in the 6800 implementation reflect the fact that,
+* on the development system, it was convenient to
+* write-protect memory at hex 1000, and leave the first
+* 4K bytes write-enabled. As a consequence, code from
+* location $1000 to lable ZZZZ could be put in ROM.
+* Minor deviations from the model were made in the
+* initialization and words ?STACK and FORGET
+* in order to do this.
+* Those deviations will be altered in this
+* implementation for the 6809 -- Color Computer.
+*
+
+* MEMORY MAP for this 16K|32K system:
+* ( delineated so that systems with 4k byte write-
+* protected segments can write protect FORTH )
+*
+* addr. contents pointer init by
+* **** ******************************* ******* ******
+*
+* Coco has no ACIA!
+* ACIAC EQU $FBCE the ACIA control address and
+* ACIAD EQU ACIAC+1 data address for PROTO
+*
+MEMT32 EQU $7FFF ; Theoretical absolute end of all ram
+MEMT16 EQU $3FFF ; 16K is too tight until we no longer need disc emulation.
+MEMTOP EQU MEMT32
+*
+MASSHI EQU MEMTOP
+*
+* 3FFF|7FFF HI
+*
+* substitute for disc mass memory
+RAMSCR EQU 8 ; addresses calculate as 2 (Too much for 16K in RAM only.)
+SCRSZ EQU 1024
+* 3800|7800 LO
+MASSLO EQU MASSHI-RAMSCR*SCRSZ+1
+RAMDSK EQU MASSLO
+MEMEND EQU MASSLO
+*
+* 3800|7800 MEMEND
+* "end" of "usable ram" (If disc mass memory emulation is removed, actual end.)
+*
+* 37FF|77FF
+*
+* per-user tables
+USERSZ EQU 256 ; (Addressable by DP, must be 256 on even boundary)
+USER16 EQU 1 ; We can change these for ROMPACK or 64K.
+USER32 EQU 2 ; maybe?
+USERCT EQU USER32
+USERLO EQU MEMEND-USERSZ*USERCT
+IUP EQU USERLO
+IUPDP EQU IUP/256
+* user tables of variables
+* registers & pointers for the virtual machine
+* scratch area for potential use in something, maybe?
+*
+* 3700|7600 <== UP
+*
+* This is a really awkward place to define the disk buffer records.
+*
+* 4 buffer sectors of VIRTUAL MEMORY
+NBLK EQU 4 ; # of disc buffer blocks for virtual memory
+* Should NBLK be SCRSZ/SECTSZ?
+* each block is SECTSZ+SECTRL bytes in size,
+* holding SECTSZ characters
+SECTSZ EQU 256
+SECTRL EQU 2*NATWID ; Currently held sector number, etc.
+BUFSZ EQU (SECTSZ+SECTRL)*NBLK
+BUFBAS EQU USERLO-BUFSZ
+* *BUG* SECTRL is hard-wired into several definitions.
+* It will take a bit of work to ferret them out.
+* It is too small, and it should not be hard-wired.
+* SECTSZ was also hard-wired into several definitions,
+* will I find them all?
+*
+* 32E0|71E0 FIRST
+*
+ PAGE
+*
+* Don't want one return too many to destroy the disc buffers.
+RPBUMP EQU 4*NATWID
+*
+* 32D8|71D8 <== RP RINIT
+*
+IRP EQU BUFBAS-RPBUMP
+* RETURN STACK
+RSTK16 EQU $50*NATWID ; 80 max levels nesting calls
+RSTK32 EQU $90*NATWID ; 144 max
+RSTKSZ EQU RSTK32
+*
+* 3248|70B8
+*
+SFTBND EQU IRP-RSTKSZ ; (false boundary between TIB and return stack)
+* INPUT LINE BUFFER
+* holds up to TIBSZ characters
+* and is scanned upward by IN
+* starting at TIB
+TIBSZ EQU 256
+ITIB EQU SFTBND-TIBSZ
+*
+* 3148|6FB8 <== IN TIB
+*
+* Don't want terminal input and parameter underflow collisions
+SPBUMP EQU 4*NATWID
+*
+ISP EQU ITIB-SPBUMP
+*
+* 3140|6FB0 <== SP SP0,SINIT
+* DATA STACK
+* | grows downward from 3140|6FB0
+* v
+* - -
+* ^
+* |
+* I DICTIONARY grows upward
+*
+* >>>>>>--------Two words to start RAMmable dictionary--------<<<<<<
+*
+* (2B00)
+* ???? end of ram-dictionary. <== DICTPT DPINIT
+* "TASK"
+*
+* ???? "FORTH" ( a word ) <=, <== CONTEXT
+* `==== CURRENT
+* start of ram-dictionary.
+*
+* >>>>>> memory from here up must be in RAM area <<<<<<
+*
+* ????
+* 6k of romable "FORTH" <== IP ABORT
+* <== W
+* the VIRTUAL FORTH MACHINE
+*
+* 1208 initialization tables
+* 1204 <<< WARM START ENTRY >>>
+* 1200 <<< COLD START ENTRY >>>
+* 1200 lowest address used by FORTH
+*
+CODEBG EQU $1200
+* CODEBG EQU $3000
+*
+* >>>>>> memory from here down left alone <<<<<<
+* >>>>>> so we can safely call ROM routines <<<<<<
+*
+* 0000
+ PAGE
+***
+*
+* CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
+*
+* IP (hardware Y) points to the current instruction ( pre-increment mode )
+* RP (hardware S) points to last return address pushedin return stack
+* SP (hardware U) points to last byte pushed in data stack
+*
+* Y must be IP when NEXT is entered (if using the inner loop).
+*
+* When A and B hold one 16 bit FORTH data word,
+* A contains the high byte, B, the low byte.
+*
+* UP (hardware DP) is the base of per-task ("user") variables.
+* (Be careful of the stray semantics of "user".)
+*
+* W (hardware X) is the pointer to the "code field" address of native CPU
+* machine code to be executed for the definition of the dictionary word
+* to be executed/currently executing.
+* The following natural integer (word) begins any "parameter section"
+* (body) -- similar to a "this" pointer, but not the same.
+* It may be native CPU machine code, or it may be a global variable,
+* or it may be a list of Forth definition words (addresses).
+*
+* ======
+* This implementation uses the native subroutine architecture
+* rather than a postponed-push call that the 6800 model VM uses
+* to save code and time in leaf routines.
+*
+* This should allow directly calling many of the Forth words
+* from assembly language code.
+* (Be aware of the need for a valid W in some cases.)
+* It won't allow mixing assembly language directly into Forth word lists.
+* ======
+*
+* boolean flags:
+* 0 is false, anything else is true.
+* Most places in this model that set a boolean flag set true as 1.
+* This is in contrast to many models that set a boolean flag as -1.
+*
+***
+
+ PAGE
+* This system is shown with one user (task),
+* but additional users (tasks) may be added
+* by allocating additional user tables:
+*
+ ORG IUP
+UBASE RMB USERSZ
+UBASEX RMB USERSZ data table for extra users
+*
+* Some of this stuff gets initialized during
+* COLD start and WARM start:
+* [ names correspond to FORTH words of similar (no X) name ]
+*
+ ORG IUP
+UORIG EQU *
+* A few useful VM variables
+* Will be removed when they are no longer needed.
+* All are replaced by 6809 registers.
+
+N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
+* SP@,SWAP,DOES>,COLD
+
+
+* These locations are used by the TRACE routine :
+
+TRLIM RMB 1 the count for tracing without user intervention
+TRACEM RMB 1 non-zero = trace mode
+BRKPT RMB 2 the breakpoint address at which
+* the program will go into trace mode
+VECT RMB 2 vector to machine code
+* (only needed if the TRACE routine is resident)
+
+
+* Registers used by the FORTH virtual machine:
+* Starting at $OOFO:
+
+
+W RMB 2 the instruction register points to 6800 code
+* This is not exactly accurate. Points to the definiton body,
+* which is native CPU machine code when it is native CPU machine code.
+* IP RMB 2 the instruction pointer points to pointer to 6800 code
+* RP RMB 2 the return stack pointer
+* UP RMB 2 the pointer to base of current user's 'USER' table
+* ( altered during multi-tasking )
+*
+*UORIG RMB 6 3 reserved variables
+ RMB 6 3 reserved variables
+XSPZER RMB 2 initial top of data stack for this user
+XRZERO RMB 2 initial top of return stack
+XTIB RMB 2 start of terminal input buffer
+XWIDTH RMB 2 name field width
+XWARN RMB 2 warning message mode (0 = no disc)
+XFENCE RMB 2 fence for FORGET
+XDICTP RMB 2 dictionary pointer
+XVOCL RMB 2 vocabulary linking
+XBLK RMB 2 disc block being accessed
+XIN RMB 2 scan pointer into the block
+XOUT RMB 2 cursor position
+XSCR RMB 2 disc screen being accessed ( O=terminal )
+XOFSET RMB 2 disc sector offset for multi-disc
+XCONT RMB 2 last word in primary search vocabulary
+XCURR RMB 2 last word in extensible vocabulary
+XSTATE RMB 2 flag for 'interpret' or 'compile' modes
+XBASE RMB 2 number base for I/O numeric conversion
+XDPL RMB 2 decimal point place
+XFLD RMB 2
+XCSP RMB 2 current stack position, for compile checks
+XRNUM RMB 2
+XHLD RMB 2
+XDELAY RMB 2 carriage return delay count
+XCOLUM RMB 2 carriage width
+IOSTAT RMB 2 last acia status from write/read
+ RMB 2 ( 4 spares! )
+ RMB 2
+ RMB 2
+ RMB 2
+
+
+
+
+*
+*
+* end of user table, start of common system variables
+*
+*
+* These need to be moved to where they will be
+* initialized globals in variable space, not in the USER table.
+* Or, more accurately, need to be turned into monitored or semaphored resources.
+XUSE RMB 2
+XPREV RMB 2
+ RMB 4 ( spares )
+
+ PAGE
+* The FORTH program ( address $1200 to about $27FF ) will be written
+* so that it can be in a ROM, or write-protected if desired,
+* but right now we're just getting it running.
+ ORG CODEBG
+
+* ######>> screen 3 <<
+*
+***************************
+** C O L D E N T R Y **
+***************************
+ORIG NOP
+* JMP CENT
+ LBRA CENT
+***************************
+** W A R M E N T R Y **
+***************************
+ NOP
+* JMP WENT warm-start code, keeps current dictionary intact
+ LBRA WENT warm-start code, keeps current dictionary intact
+ SETDP IUPDP
+
+*
+******* startup parmeters **************************
+*
+ FDB $6809,0000 cpu & revision
+ FDB 0 topmost word in FORTH vocabulary
+* BACKSP FDB $7F backspace character for editing
+BACKSP FDB $08 backspace character for editing
+UPINIT FDB UORIG initial user area
+* UPINIT FDB UORIG initial user area
+SINIT FDB ISP ; initial top of data stack
+* SINIT FDB ORIG-$D0 initial top of data stack
+RINIT FDB IRP ; initial top of return stack
+* RINIT FDB ORIG-2 initial top of return stack
+ FDB ITIB ; terminal input buffer
+* FDB ORIG-$D0 terminal input buffer
+ FDB 31 initial name field width
+ FDB 0 initial warning mode (0 = no disc)
+FENCIN FDB REND initial fence
+DPINIT FDB REND cold start value for DICTPT
+BUFINT FDB BUFBAS Start of the disk buffers area
+VOCINT FDB FORTH+4*NATWID
+COLINT FDB TIBSZ initial terminal carriage width
+DELINT FDB 4 initial carriage return delay
+****************************************************
+*
+ PAGE
+*
+* ######>> screen 13 <<
+* These were of questionable use anyway,
+* kept here now to satisfy the assembler and show hints.
+* They're too much trouble to use with native subroutine call anyway.
+* PULABX PULS A ; 24 cycles until 'NEXT'
+* PULS B ;
+* PULABX PULU A,B ; ?? cycles until 'NEXT'
+* STABX STA 0,X 16 cycles until 'NEXT'
+* STB 1,X
+* STABX STD 0,X ; ?? cycles until 'NEXT'
+* BRA NEXT
+* GETX LDA 0,X 18 cycles until 'NEXT'
+* LDB 1,X
+* GETX LDD 0,X ?? cycles until 'NEXT'
+* PUSHBA PSHS B ; 8 cycles until 'NEXT'
+* PSHS A ;
+* PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
+
+
+*
+* "NEXT" takes ?? cycles if TRACE is removed,
+*
+* and ?? cycles if trace is present and NOT tracing.
+*
+* = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
+* =
+* NEXT itself might just completely go away.
+* About the only reason to keep it is to allowing executing a list
+* which allows a cheap TRACE routine.
+*
+* NEXT is a loop which implements the Forth VM.
+* It basically cycles through calling the code out of code lists,
+* one at a time.
+* Using a native CPU return for this uses a few extra cycles per call,
+* compared to simply jumping to each definition and jumping back
+* to the known beginning of the loop,
+* but the loop itself is really only there for convenience.
+*
+* This implementation uses the native subroutine call,
+* to break the wall between Forth code and non-Forth code.
+*
+* NEXT LDX IP
+* LEAX 1,X ; pre-increment mode
+* LEAX 1,X ;
+* STX IP
+NEXT ; IP is Y, push before using, pull before you come back here.
+*
+* NEXT2 LDX 0,X get W which points to CFA of word to be done
+NEXT2 LDX ,Y++ get W which points to CFA of word to be done
+ BSR DBGNAM
+ BSR DBGREG
+* But NEXT2 is too much trouble to use with subroutine threading anyway.
+* NEXT3 STX W
+NEXT3 ; W is X until you use X for something else. (TOS points back here.)
+* But NEXT3 is too much trouble to use with subroutine threading anyway.
+* LDX 0,X get VECT which points to executable code
+* =
+* The next instruction could be patched to JMP TRACE =
+* if a TRACE routine is available: =
+* =
+* JMP 0,X
+
+ JMP [,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'
+ LBNE 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
+ LDD ,Y++
+ LBSR OUThxA
+ LDA #$9F
+ STA ,X+
+ LBSR OUThxB
+ LDD ,Y++
+ LBSR OUThxA
+ LDA #$9F
+ STA ,X+
+ LBSR OUThxB
+ LDA #$58 ; X
+ STA ,X+
+ LDD ,Y++
+ LBSR OUThxD
+ LDA #$59 ; Y
+ STA ,X+
+ LDD ,Y++
+ LBSR OUThxD
+ LDA #$55 ; U
+ STA ,X+
+ LDD ,Y++
+ LBSR OUThxD
+ LDA #$50 ; PC
+ STA ,X+
+ LDD ,Y++
+ LBSR OUThxD
+ LDA #$53 ; Stack
+ STA ,X+
+ 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
+ LDB #$FF
+ STB ,X+
+DBGRrt PULS CC,A,B,DP,X,Y,U,PC
+DBGRLB FCC 'DPCC PC S U Y X A B '
+ FDB 0,0
+
+
+*
+* =
+* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+
+
+ PAGE
+*
+* ======>> 1 <<
+* ( --- n )
+* Pushes the following natural width integer from the instruction stream
+* as a literal, or immediate value.
+*
+* FDB {OP}
+* FDB {OP}
+* FDB LIT
+* FDB LITERAL-TO-BE-PUSHED
+* FDB {OP}
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* (Note that there is no compile-only flag in the fig model.)
+*
+* See (FIND), or PFIND , for layout of the header format.
+*
+ FCB $83
+ FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
+ FCB $D4 ; 'T'|'\x80' ; character code for T, with high bit set.
+ FDB 0 ; link of zero to terminate dictionary scan
+LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
+ LDD ,Y++
+ PSHU A,B
+ LBRA NEXT
+* LDX IP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX IP
+* LDA 0,X
+* LDB 1,X
+* JMP PUSHBA
+*
+* ######>> screen 14 <<
+* ======>> 2 <<
+* ( --- n )
+* Pushes the following byte from the instruction stream
+* as a literal, or immediate value.
+*
+* FDB {OP}
+* FDB {OP}
+* FDB LIT8
+* FCB LITERAL-TO-BE-PUSHED
+* FDB {OP}
+*
+* If this is kept, it should have a header for TRACE to read.
+* If the data bus is wider than a byte, you don't want to do this.
+* Byte shaving like this is often counter-productive anyway.
+* Changing the name to LIT8, hoping that will be more understandable.
+* Also, see comments for LIT.
+* (Note that there is no compile-only flag in the fig model.)
+ FCB $84
+ FCC 'LIT' ; 'LIT8' : NOTE: this is different from LITERAL
+ FCB $B8
+ FDB LIT-6
+LIT8 FDB *+NATWID (this was an invisible word, with no header)
+ LDB ,Y+ ; This also is meaningless in native code.
+ CLRA
+ PSHU A,B
+ LBRA NEXT
+* 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
+ JMP NEXT
+*
+ FCB $85
+ FCC 'TROF' ; 'TROFF'
+ FCB $C6 ; 'F'|$80
+ FDB SHOTOS-10
+TROFF FDB *+NATWID
+ CLR <TRACEM
+ JMP NEXT
+*
+ FCB $84
+ FCC 'TRO' ; 'TRON'
+ FCB $CE ; 'N'|$80
+ FDB TROFF-8
+TRON FDB *+NATWID
+ INC <TRACEM
+ JMP NEXT
+*
+* ======>> 3 <<
+* ( adr --- )
+* Jump to address on stack. Used by the "outer" interpreter to
+* interactively invoke routines.
+* Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
+ FCB $87
+ FCC 'EXECUT' ; 'EXECUTE'
+ FCB $C5
+ FDB TRON-7
+EXEC FDB *+NATWID
+ PULU X ; Gotta have W anyway, just in case.
+ JMP [,X] ; Tail return.
+* TFR S,X ; TSX :
+* LDX 0,X get code field address (CFA)
+* LEAS 1,S ; pop stack
+* LEAS 1,S ;
+* JMP NEXT3
+*
+* ######>> screen 15 <<
+* ======>> 4 <<
+* ( --- ) C
+* Add the following word from the instruction stream to the
+* instruction pointer (Y++). Causes a program branch in Forth code stream.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $86
+ FCC 'BRANC' ; 'BRANCH'
+ FCB $C8
+ FDB EXEC-10
+BRAN FDB ZBYES ; Go steal code in ZBRANCH
+
+* Moving code around to optimize the branch taking case in 0BRANCH.
+ZBNO LEAY NATWID,Y ; No branch.
+ JMP NEXT
+* ======>> 5 <<
+* ( f --- ) C
+* BRANCH if flag is zero.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $87
+ FCC '0BRANC' ; '0BRANCH'
+ FCB $C8
+ FDB BRAN-9
+ZBRAN FDB *+NATWID
+ LDD ,U++
+ BNE ZBNO
+ZBYES LDD ,Y++
+ LEAY D,Y ; IP is postinc
+ JMP NEXT
+* 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 <<
+
+******* Continue from the LOOP variables ********
+
+
+* ======>> 6 <<
+* ( --- ) ( limit index *** limit index+1) C
+* ( limit index *** )
+* Counting loop primitive. The counter and limit are the top two
+* words on the return stack. If the updated index/counter does
+* not exceed the limit, a branch occurs. If it does, the branch
+* does not occur, and the index and limit are dropped from the
+* return stack.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $86
+ FCC '(LOOP' ; '(LOOP)'
+ FCB $A9
+ FDB ZBRAN-10
+XLOOP FDB *+NATWID
+ LDD #1 ; Borrowing from BIF-6809.
+XLOOPA ADDD ,S ; No return address to dodge.
+ STD ,S
+ SUBD NATWID,S
+ BMI ZBYES ; pseudo-signed-unsigned
+XLOOPN LEAY NATWID,Y
+ LEAS 2*NATWID,S ; Clean up the index and limit.
+ LBRA NEXT
+* CLRA ;
+* LDB #1 get set to increment counter by 1 (Clears N.)
+* BRA XPLOP2 go steal other guy's code!
+*
+* ======>> 7 <<
+* ( n --- ) ( limit index *** limit index+n ) C
+* ( limit index *** )
+* Loop with a variable increment. Terminates when the index
+* crosses the boundary from one below the limit to the limit. A
+* positive n will cause termination if the result index equals the
+* limit. A negative n must cause the index to become less than
+* the limit to cause loop termination.
+*
+* Note that the end conditions are not symmetric around zero.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $87
+ FCC '(+LOOP' ; '(+LOOP)'
+ FCB $A9
+ FDB XLOOP-9
+XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
+ LDD ,U++ ; inc val
+ BPL XLOOPA ; Steal plain loop code for forward count.
+ ADDD ,S ; No return address to dodge
+ STD ,S
+ SUBD NATWID,S
+ BPL ZBYES ; pseudo-signed-unsigned
+ BRA XLOOPN ; This path might be less time-sensitive.
+*
+* This should work, but I want to use tested code.
+* PULU A,B ; Get the increment.
+* XPLOP2 PULS X ; Pre-clear the return stack.
+* PSHU A ; Save the direction in high bit.
+* ADDD ,S ; Count.
+* STD ,S ; Update.
+* SUBD NATWID,S ; Check limit.
+**
+** I think this should work:
+* EORA ,U+ ; dir < 0 and (count - limit) >= 0
+* BPL XPLONO ; or dir >= 0 and (count - limit) < 0
+* LDD ,Y++
+* LEAY D,Y ; IP is postinc
+* JMP ,X
+* XPLONO LEAS 2*NATWID,S
+* JMP ,X ; synthetic return
+*
+* This definitely should work:
+* TST ,U+ ; Get the sign
+* BPL XPLOF ;
+* CMPD NATWID,S
+* BMI XPLONO
+* XPLOYE LDD ,Y++
+* LEAY D,Y ; IP is postinc
+* JMP ,X
+* XPLOF CMPD NATWID,S
+* BMI XPLOYE
+* XPLONO LEAS 2*NATWID,S
+* JMP ,X ; synthetic return
+*
+* 6800 Probably could have used the exclusive-or method, too.:
+* PULS A ; get increment
+* PULS B ;
+* XPLOP2 TSTA ;
+* BPL XPLOF forward looping
+* BSR XPLOPS
+* ORCC #$01 ; SEC :
+* SBCB 5,X
+* SBCA 4,X
+* BPL ZBYES
+* BRA XPLONO fall through
+*
+* the subroutine :
+* XPLOPS LDX RP
+* ADDB 3,X add it to counter
+* ADCA 2,X
+* STB 3,X store new counter value
+* STA 2,X
+* RTS
+*
+* XPLOF BSR XPLOPS
+* SUBB 5,X
+* SBCA 4,X
+* BMI ZBYES
+*
+* XPLONO LEAX 1,X ; done, don't branch back
+* LEAX 1,X ;
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX RP
+* BRA ZBNO use ZBRAN to skip over unused delta
+*
+* ######>> screen 17 <<
+* ======>> 8 <<
+* ( limit index --- ) ( *** limit index )
+* Move the loop parameters to the return stack. Synonym for D>R.
+ FCB $84
+ FCC '(DO' ; '(DO)'
+ FCB $A9
+ FDB XPLOOP-10
+XDO FDB *+NATWID This is the RUNTIME DO, not the COMPILING DO
+ PULU D,X
+ PSHS D,X ; Ends up same order.
+ LBRA NEXT ; No return address to mess with.
+*
+* LDX RP
+* LEAX -1,X ;
+* LEAX -1,X ;
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* PULS A ;
+* PULS B ;
+* STA 2,X
+* STB 3,X
+* PULS A ;
+* PULS B ;
+* STA 4,X
+* STB 5,X
+* JMP NEXT
+*
+* ======>> 9 <<
+* ( --- index ) ( limit index *** limit index )
+* Copy the loop index from the return stack. Synonym for R.
+ FCB $81 I
+ FCB $C9
+ FDB XDO-7
+I FDB *+NATWID
+ LDD ,S ; No return address to dodge.
+ PSHU D
+ LBRA NEXT
+* LDX RP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* JMP GETX
+*
+* ######>> screen 18 <<
+* ======>> 10 <<
+* ( c base --- false )
+* ( c base --- n true )
+* Translate C in base, yielding a translation valid flag. If the
+* translation is not valid in the specified base, only the false
+* flag is returned.
+ FCB $85
+ FCC 'DIGI' ; 'DIGIT'
+ FCB $D4
+ FDB I-4
+DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
+ LDD NATWID,U ; Check the whole thing.
+ SUBD #$30 ; ascii zero
+ BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+ CMPD #$A
+ BMI DIGIT0 IF '9' OR LESS
+ CMPD #$11
+ BMI DIGIT2 if less than 'A'
+ CMPD #$2B
+ BPL DIGIT2 if greater than 'Z'
+ SUBD #7 translate 'A' thru 'F'
+DIGIT0 CMPD ,U ; Check the base.
+ BPL DIGIT2 if not less than the base
+ STD NATWID,U ; Store converted digit. (High byte known zero.)
+ LDD #1 ; set valid flag
+DIGIT1 STD ,U ; store the flag
+ LBRA NEXT
+DIGIT2 LDD #0 ; set not valid flag
+ LEAU NATWID,U ; pop base
+ BRA DIGIT1
+* TFR S,X ; TSX :
+* LDA 3,X
+* SUBA #$30 ascii zero
+* BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+* CMPA #$A
+* BMI DIGIT0 IF '9' OR LESS
+* CMPA #$11
+* BMI DIGIT2 if less than 'A'
+* CMPA #$2B
+* BPL DIGIT2 if greater than 'Z'
+* SUBA #7 translate 'A' thru 'F'
+* DIGIT0 CMPA 1,X
+* BPL DIGIT2 if not less than the base
+* LDB #1 set flag
+* STA 3,X store digit
+* DIGIT1 STB 1,X store the flag
+* JMP NEXT
+* DIGIT2 CLRB ;
+* LEAS 1,S ;
+* LEAS 1,S ; pop bottom number
+* TFR S,X ; TSX :
+* STB 0,X make sure both bytes are 00
+* BRA DIGIT1
+*
+* ######>> screen 19 <<
+*
+* The word definition format in the dictionary:
+*
+* (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
+*
+* NFA (name field address):
+* char-count + $80 Length of symbol name, flagged with high bit set.
+* char 1 Characters of symbol name.
+* char 2
+* ...
+* char n + $80 symbol termination flag (char set < 128 code points)
+* LFA (link field address):
+* link high byte \___pointer to previous word in list
+* link low byte / -- Combined allocation/dictionary list. --
+* CFA (code field address):
+* CFA high byte \___pointer to native CPU machine code
+* CFA low byte / -- Consider this the characteristic code. --
+* PFA (parameter field address):
+* parameter fields -- Machine code for low-level native machine CPU code,
+* " instruction list for high-level Forth code,
+* " constant data for constants, pointers to per task variables,
+* " space for variables, for global variables, etc.
+*
+* In the case of native CPU machine code, the address at CFA will be PFA.
+
+* Definition attributes:
+FIMMED EQU $40 ; Immediate word flag.
+FSMUDG EQU $20 ; Smudged => definition not ready.
+CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte.
+* Note that the SMUDGE bit is not masked out.
+*
+* But we really want more (Thinking for a new model, need one more byte):
+* FCOMPI EQU $10 ; Compile-time-only.
+* FASSEM EQU $08 ; Assembly-language code only.
+* F4THLV EQU $04 ; Must not be called from assembly language code.
+* These would require some significant adjustments to the model.
+* We also want to put the low-level VM stuff in its own vocabulary.
+*
+* ======>> 11 <<
+* (FIND) ( name vocptr --- locptr length true )
+* ( name vocptr --- false )
+* Search vocabulary for a symbol called name.
+* name is a pointer to a high-bit bracket string with length head.
+* vocptr is a pointer to the NFA of the tail-end (LATEST) definition
+* in the vocabulary to be searched.
+* Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
+ FCB $86
+ FCC '(FIND' ; '(FIND)'
+ FCB $A9
+ FDB DIGIT-8
+PFIND FDB *+NATWID
+ PSHS Y ; Have to track two pointers.
+* Use the stack and registers instead of temp area N.
+PA0 EQU NATWID ; pointer to the length byte of name being searched against
+PD EQU 0 ; pointer to NFA of dict word being checked
+*
+* INC <TRACEM
+* LBSR DBGREG
+ LDX PD,U ; Start in on the vocabulary (NFA).
+PFNDLP LDY PA0,U ; Point to the name to check against.
+ LDB ,X+ ; get dict name length byte
+ TFR B,A ; Save it in case it matches.
+ ANDB #CTMASK
+* LBSR DBGREG
+ CMPB ,Y+ ; Compare lengths
+* LBSR DBGREG
+ BNE PFNDUN
+PFNDBR LDB ,X+
+ TSTB ; ; Is high bit of character in dictionary entry set?
+* LBSR DBGREG
+ BPL PFNDCH
+* LBSR DBGREG
+ ANDB #$7F ; Clear high bit from dictionary.
+ CMPB ,Y+ ; Compare "last" characters.
+* LBSR DBGREG
+ BEQ FOUND ; Matches even if dictionary actual length is shorter.
+PFNDLN LDX ,X++ ; Get previous link in vocabulary.
+* LBSR DBGREG
+ BNE PFNDLP ; Continue if link not=0
+*
+* not found :
+ LEAU NATWID,U ; Return only false flag.
+ LDD #0
+ STD ,U
+* LBSR DBGREG
+* DEC <TRACEM
+ PULS Y
+ LBRA NEXT
+*
+PFNDCH CMPB ,Y+ ; Compare characters.
+* LBSR DBGREG
+ BEQ PFNDBR
+PFNDUN
+PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
+* LBSR DBGREG
+ BPL PFNDSC
+* LBSR DBGREG
+ BRA PFNDLN
+*
+* found :
+*
+FOUND LEAX 2*NATWID,X
+* LBSR DBGREG
+ STX NATWID,U
+ TFR A,B
+ CLRA
+ STD ,U
+* LBSR DBGREG
+ LDB #1
+ PSHU A,B
+* LBSR DBGREG
+* DEC <TRACEM
+ PULS Y
+ LBRA NEXT
+*
+* 6800 model:
+* NOP ; Probably leftovers from a debugging session.
+* NOP
+* PD EQU N ptr to dict word being checked
+* PA0 EQU N+2
+* PA EQU N+4
+* PC EQU N+6
+* LDX #PD
+* LDB #4
+* PFIND0 PULS A ; loop to get arguments
+* STA 0,X
+* LEAX 1,X ;
+* DECB ;
+* BNE PFIND0
+*
+* LDX PD
+* PFNDLP LDB 0,X get count dict count
+* STB PC
+* ANDB #$3F
+* LEAX 1,X ;
+* STX PD update PD
+* LDX PA0
+* LDA 0,X get count from arg
+* LEAX 1,X ;
+* STX PA intialize PA
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ; compare lengths
+* BNE PFNDUN
+* PFNDBR LDX PA
+* LDA 0,X
+* LEAX 1,X ;
+* STX PA
+* LDX PD
+* LDB 0,X
+* LEAX 1,X ;
+* STX PD
+* TSTB ; is dict entry neg. ?
+* BPL PFNDCH
+* ANDB #$7F clear sign
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ;
+* BEQ FOUND
+* PFNDLN LDX 0,X get new link
+* BNE PFNDLP continue if link not=0
+*
+* not found :
+*
+* CLRA ;
+* CLRB ;
+* JMP PUSHBA
+* PFNDCH PSHS B ; ** emulating CBA:
+* CMPA ,S+ ;
+* BEQ PFNDBR
+* PFNDUN LDX PD
+* PFNDSC LDB 0,X scan forward to end of this name
+* LEAX 1,X ;
+* BPL PFNDSC
+* BRA PFNDLN
+*
+* found :
+*
+* FOUND LDA PD compute CFA
+* LDB PD+1
+* ADDB #4
+* ADCA #0
+* PSHS B ;
+* PSHS A ;
+* LDA PC
+* PSHS A ;
+* CLRA ;
+* PSHS A ;
+* LDB #1
+* JMP PUSHBA
+*
+* PSHS A ; Left over from a stray copy-paste, I guess.
+* CLRA ;
+* PSHS A ;
+* LDB #1
+* JMP PUSHBA
+*
+* ######>> screen 20 <<
+* ======>> 12 <<
+* ( buffer ch --- buffer symboloffset delimiteroffset scancount )
+* ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
+* ( buffer ch --- buffer nuloffset onepast scancount )
+* Scan buffer for a symbol delimited by ch or ASCII NUL,
+* return the length of the buffer region scanned,
+* the offset to the trailing delimiter,
+* and the offset of the first character of the symbol.
+* Leave the buffer on the stack.
+* Scancount is also offset to first character not yet looked at.
+* If no symbol in buffer, scancount and symboloffset point to NUL
+* and delimiteroffset points one beyond for some reason.
+* On trailing NUL, delimiteroffset == scancount.
+* (Buffer is the address of the buffer array to scan.)
+* (This is a bit too tricky, really.)
+ FCB $87
+ FCC 'ENCLOS' ; 'ENCLOSE'
+ FCB $C5
+ FDB PFIND-9
+ENCLOS FDB *+NATWID
+ LDA 1,U ; Delimiter character to match against in A.
+ LDX NATWID,U ; Buffer to scan in.
+ CLRB ; Initialize offset. (Buffer < 256 wide!)
+* Scan to a non-delimiter or a NUL
+ENCDEL TST B,X ; NUL ?
+ BEQ ENCNUL
+ CMPA B,X ; Delimiter?
+ BNE ENC1ST
+ INCB ; count character
+ BRA ENCDEL
+* Found first character. Save the offset.
+ENC1ST STB 1,U ; Found first non-delimiter character --
+ CLR ,U ; store the count, zero high byte.
+* Scan to a delimiter or a NUL
+ENCSYM TST B,X ; NUL ?
+ BEQ ENC0TR
+ CMPA B,X ; delimiter?
+ BEQ ENCEND
+ INCB
+ BRA ENCSYM
+* Found end of symbol. Push offset to delimiter found.
+ENCEND CLRA ; high byte -- buffer < 255 wide!
+ PSHU A,B ; Offset to seen delimiter.
+* Advance and push address of next character to check.
+ ADDD #1 ; In case offset was 255.
+ PSHU A,B
+ LBRA NEXT
+* 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.
+ LBRA NEXT
+* 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
+ LBRA NEXT
+* NOTE :
+* FC means offset (bytes) to First Character of next word
+* EW " " to End of Word
+* NC " " to Next Character to start next enclose at
+* ENCLOS FDB *+NATWID
+* LEAS 1,S ;
+* PULS B ; now, get the low byte, for an 8-bit delimiter
+* TFR S,X ; TSX :
+* LDX 0,X
+* CLR N
+* * wait for a non-delimiter or a NUL
+* ENCDEL LDA 0,X
+* BEQ ENCNUL
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ; CHECK FOR DELIM
+* BNE ENC1ST
+* LEAX 1,X ;
+* INC N
+* BRA ENCDEL
+* * found first character. Push FC
+* ENC1ST LDA N found first char.
+* PSHS A ;
+* CLRA ;
+* PSHS A ;
+* wait for a delimiter or a NUL
+* ENCSYM LDA 0,X
+* BEQ ENC0TR
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ; ckech for delim.
+* BEQ ENCEND
+* LEAX 1,X ;
+* INC N
+* BRA ENCSYM
+* * found EW. Push it
+* ENCEND LDB N
+* CLRA ;
+* PSHS B ;
+* PSHS A ;
+* * advance and push NC
+* INCB ;
+* JMP PUSHBA
+* found NUL before non-delimiter, therefore there is no word
+* ENCNUL LDB N found NUL
+* PSHS B ;
+* PSHS A ;
+* INCB ;
+* BRA ENC0TR+2 ; ********** POTENTIAL BUG HERE *******
+* ******** Should use labels in case opcodes change! ********
+* found NUL following the word instead of SPACE
+* ENC0TR LDB N
+* PSHS B ; save EW
+* PSHS A ;
+* ENCL8 LDB N save NC
+* JMP PUSHBA
+
+ PAGE
+*
+* ######>> screen 21 <<
+* The next 4 words call system dependant I/O routines
+* which are listed after word "-->" ( lable: "arrow" )
+* in the dictionary.
+*
+* ======>> 13 <<
+* ( c --- )
+* Write c to the output device (screen or printer).
+* ROM Uses the ECB device number at address $6F,
+* -2 is printer, 0 is screen.
+ FCB $84
+ FCC 'EMI' ; 'EMIT'
+ FCB $D4
+ FDB ENCLOS-10
+EMIT FDB *+NATWID
+ PULU D
+ LBSR PEMIT ; PEMIT expects the character in D.
+ INC <XOUT+1
+ BNE EMITDN
+ INC <XOUT
+EMITDN LBRA NEXT
+* PULS A ;
+* PULS A ;
+* JSR PEMIT
+* LDX UP
+* INC XOUT+1-UORIG,X
+* BNE *+4 ;
+* ****WARNING**** HARD OFFSET: *+4 ****
+* INC XOUT-UORIG,X
+* JMP NEXT
+*
+* ======>> 14 <<
+* ( --- c )
+* ( --- BREAK )
+* Wait for a key from the keyboard.
+* If the key is BREAK, set the high byte (result $FF03).
+ FCB $83
+ FCC 'KE' ; 'KEY'
+ FCB $D9
+ FDB EMIT-7
+KEY FDB *+NATWID
+ LBSR PKEY ; PKEY leaves the key/break code in D.
+ PSHU D
+ LBRA NEXT
+* JSR PKEY
+* PSHS A ;
+* CLRA ;
+* PSHS A ;
+* JMP NEXT
+*
+* ======>> 15 <<
+* ( --- f )
+* Scan keyboard, but do not wait.
+* Return 0 if no key,
+* BREAK ($ff03) if BREAK is pressed,
+* or key currently pressed.
+ FCB $89
+ FCC '?TERMINA' ; '?TERMINAL'
+ FCB $CC
+ FDB KEY-6
+QTERM FDB *+NATWID
+ LBSR PQTER ; PQTER leaves the flag/key in D.
+ PSHU D
+ LBRA NEXT
+* JSR PQTER
+* CLRB ;
+* JMP PUSHBA stack the flag
+*
+* ======>> 16 <<
+* ( --- )
+* EMIT a Carriage Return (ASCII CR).
+ FCB $82
+ FCC 'C' ; 'CR'
+ FCB $D2
+ FDB QTERM-12
+CR FDB *+NATWID
+* LBSR DBGREG
+ LBSR PCR ; Nothing really to do here.
+ LBRA NEXT
+* JSR PCR
+* JMP NEXT
+*
+* ######>> screen 22 <<
+* ======>> 17 <<
+* ( source target count --- )
+* Copy/move count bytes from source to target.
+* Moves ascending addresses,
+* so that overlapping only works if the source is above the destination.
+ FCB $85
+ FCC 'CMOV' ; 'CMOVE' : source, destination, count
+ FCB $C5
+ FDB CR-5
+CMOVE FDB *+NATWID
+* Another way ; takes ( 42+17*count+9*(count/256) cycles )
+ LDD #0 ; #3~3
+ SUBD ,U++ ; #2~9 ; invert the count
+ PSHS A,Y ; #2~8
+ PULU X,Y ; #2~9
+ BEQ CMOVEX ; #2~3
+CMOVEL
+ LDA ,Y+ ; #2~6
+ STA ,X+ ; #2~6
+ INCB ; #1~2
+ BNE CMOVEL ; #2~3
+ INC ,S ; #2~6
+ BNE CMOVEL ; #2~3
+CMOVEX PULS A,Y ; #2~8
+ LBRA NEXT ; #3~5
+* 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
+* LBRA NEXT
+* 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
+* LBRA NEXT ; #3~5
+* 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
+* LBRA NEXT ; #3~5
+* 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
+* LBRA NEXT ; #3~5
+* 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.
+* Significantly faster than a bit method.
+ FCB $82
+ FCC 'U' ; 'U*'
+ FCB $AA
+ FDB CMOVE-8
+USTAR FDB *+NATWID
+ LEAU -2*NATWID,U
+ LDA 2*NATWID+1,U ; least
+ LDB 3*NATWID+1,U
+ MUL
+ STD NATWID,U
+ LDA 2*NATWID,U ; most
+ LDB 3*NATWID,U
+ MUL
+ STD ,U
+ LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi)
+ MUL
+ ADDD 1,U
+ BCC USTAR3
+ INC ,U
+USTAR3 STD 1,U
+ LDA 2*NATWID,U ; second inner (u2 hi)
+ LDB 3*NATWID,U ; (u1 lo)
+ MUL
+ ADDD 1,U
+ BCC USTAR4
+ INC ,U
+USTAR4 STD 1,U
+ PULU D,X
+ STD ,U
+ STX NATWID,U
+ LBRA NEXT
+*
+* 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.
+*
+* 6809 version
+* USTARS LDA #16 bits/word counter
+* PSHS A ;
+* LDD #0 ;
+* USTAR2 ROR 2,U shift multiplier
+* ROR 3,U
+* DEC 0,X done?
+* BMI USTAR4
+* BCC USTAR3
+* ADDD 2,X
+* USTAR3 RORA ;
+* RORB ; shift result
+* BRA USTAR2
+* USTAR4 LEAS 1,S ; dump counter
+* RTS
+*
+* From the 6800 model:
+* USTARS LDA #16 bits/word counter
+* PSHS A ;
+* CLRA ;
+* CLRB ;
+* TFR S,X ; TSX :
+* USTAR2 ROR 5,X shift multiplier
+* ROR 6,X
+* DEC 0,X done?
+* BMI USTAR4
+* BCC USTAR3
+* ADDB 4,X
+* ADCA 3,X
+* USTAR3 RORA ;
+* RORB ; shift result
+* BRA USTAR2
+* USTAR4 LEAS 1,S ; dump counter
+* RTS
+*
+* ######>> screen 24 <<
+* ======>> 19 <<
+* ( ud u --- uremainder uquotient )
+* Divides the top unsigned integer
+* into the second and third words on the stack
+* as a single unsigned double integer,
+* leaving the remainder and quotient (quotient on top)
+* as unsigned integers.
+*
+* The smaller the divisor, the more likely dropping the high word
+* of the quotient loses significant bits. See M/MOD .
+*
+ FCB $82
+ FCC 'U' ; 'U/'
+ FCB $AF
+ FDB USTAR-5
+USLASH FDB *+NATWID
+ LDA #17 ; bit ct
+ PSHS A
+ LDD NATWID,U ; dividend
+USLDIV CMPD ,U ; divisor
+ BHS USLSUB
+ ANDCC #~1 ; carry clear
+ BRA USLBIT
+USLSUB SUBD ,U
+ ORCC #1 ; quotient, (carry set)
+USLBIT ROL 2*NATWID+1,U ; save it
+ ROL 2*NATWID,U
+ DEC ,S ; more bits?
+ BEQ USLR
+ ROLB ; remainder
+ ROLA
+ BCC USLDIV
+ BRA USLSUB
+USLR LEAU NATWID,U
+ LDX NATWID,U
+ STD NATWID,U
+ STX ,U
+ LEAS 1,S
+ LBRA NEXT
+*
+* from 6800 model:
+* LDA #17
+* PSHS A ;
+* TFR S,X ; TSX :
+* LDA 3,X
+* LDB 4,X
+* USL1 CMPA 1,X
+* BHI USL3
+* BCS USL2
+* CMPB 2,X
+* BCC USL3
+* USL2 ANDCC #~$01 ; CLC :
+* BRA USL4
+* USL3 SUBB 2,X
+* SBCA 1,X
+* ORCC #$01 ; SEC :
+* USL4 ROL 6,X
+* ROL 5,X
+* DEC 0,X
+* BEQ USL5
+* ROLB ;
+* ROLA ;
+* BCC USL1
+* BRA USL3
+* USL5 LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP SWAP+4 reverse quotient & remainder
+*
+* ######>> screen 25 <<
+* ======>> 20 <<
+* ( n1 n2 --- n )
+* Bitwise and the top two integers.
+ FCB $83
+ FCC 'AN' ; 'AND'
+ FCB $C4
+ FDB USLASH-5
+AND FDB *+NATWID
+ PULU A,B
+ ANDB 1,U
+ ANDA ,U
+ STD ,U
+ LBRA NEXT
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* ANDB 1,X
+* ANDA 0,X
+* JMP STABX
+*
+* ======>> 21 <<
+* ( n1 n2 --- n )
+* Bitwise or the top two integers.
+ FCB $82
+ FCC 'O' ; 'OR'
+ FCB $D2
+ FDB AND-6
+OR FDB *+NATWID
+ PULU A,B
+ ORB 1,U
+ ORA ,U
+ STD ,U
+ LBRA NEXT
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* ORB 1,X
+* ORA 0,X
+* JMP STABX
+*
+* ======>> 22 <<
+* ( n1 n2 --- n )
+* Bitwise exclusive or the top two integers.
+ FCB $83
+ FCC 'XO' ; 'XOR'
+ FCB $D2
+ FDB OR-5
+XOR FDB *+NATWID
+ PULU A,B
+ EORB 1,U
+ EORA ,U
+ STD ,U
+ LBRA NEXT
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* EORB 1,X
+* EORA 0,X
+* JMP STABX
+*
+* ######>> screen 26 <<
+* ======>> 23 <<
+* ( --- adr )
+* Fetch the parameter stack pointer (before it is pushed).
+* This points at whatever was on the top of stack before.
+ FCB $83
+ FCC 'SP' ; 'SP@'
+ FCB $C0
+ FDB XOR-6
+SPAT FDB *+NATWID
+ TFR U,X
+ PSHU X
+ LBRA NEXT
+* TFR S,X ; TSX :
+* STX N scratch area
+* LDX #N
+* JMP GETX
+*
+* ======>> 24 <<
+* ( whatever --- nothing )
+* Initialize the parameter stack pointer from the USER variable S0.
+* Effectively clears the stack.
+ FCB $83
+ FCC 'SP' ; 'SP!'
+ FCB $A1
+ FDB SPAT-6
+SPSTOR FDB *+NATWID
+ LDU <XSPZER
+ LBRA NEXT
+* LDX UP
+* LDX XSPZER-UORIG,X
+* TFR X,S ; TXS : watch it ! X and S are not equal on 6800.
+* JMP NEXT
+* ======>> 25 <<
+* ( whatever *** nothing )
+* Initialize the return stack pointer from the initialization table
+* instead of the user variable R0, for some reason.
+* Quite possibly, this should be from R0.
+* Effectively aborts all in process definitions, except the active one.
+* An emergency measure, to be sure.
+* The routine that calls this must never execute a return.
+* So this should never be executed from the terminal, I guess.
+* This is another that should be compile-time only, and in a separate vocabulary.
+ FCB $83
+ FCC 'RP' ; 'RP!'
+ FCB $A1
+ FDB SPSTOR-6
+RPSTOR FDB *+NATWID
+ LDS RINIT,PCR
+* LBSR DBGREG
+ LBRA NEXT
+* LDX RINIT initialize from rom constant
+* STX RP
+* JMP NEXT
+*
+* ======>> 26 <<
+* ( ip *** )
+* Pop IP from return stack (return from high-level definition).
+* Can be used in a screen to force interpretion to terminate.
+* Must not be executed when temporaries are saved on top of the return stack.
+ FCB $82
+ FCC ';' ; ';S'
+ FCB $D3
+ FDB RPSTOR-6
+SEMIS FDB *+NATWID
+* LBSR DBGREG
+ PULS Y ; saved IP in Y.
+ LBRA NEXT
+*
+* Form 6800 model:
+* LDX RP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX RP
+* LDX 0,X get address we have just finished.
+* JMP NEXT+2 increment the return address & do next word
+*
+* ######>> screen 27 <<
+* ======>> 27 <<
+* ( limit index *** index index )
+* Force the terminating condition for the innermost loop by
+* copying its index to its limit.
+* Termination is postponed until the next
+* LOOP or +LOOP instruction is executed.
+* The index remains available for use until
+* the LOOP or +LOOP instruction is encountered.
+* Note that the assumption is that the current count is the correct count
+* to end at, rather than pushing the count to the final count.
+ FCB $85
+ FCC 'LEAV' ; 'LEAVE'
+ FCB $C5
+ FDB SEMIS-5
+LEAVE FDB *+NATWID
+ LDD ,S ; No return address to dodge.
+ STD NATWID,S
+ LBRA NEXT
+* LDX RP
+* LDA 2,X
+* LDB 3,X
+* STA 4,X
+* STB 5,X
+* JMP NEXT
+*
+* ======>> 28 <<
+* ( n --- )
+* ( *** n )
+* Move top of parameter stack to top of return stack.
+ FCB $82
+ FCC '>' ; '>R'
+ FCB $D2
+ FDB LEAVE-8
+TOR FDB *+NATWID
+ PULU D
+ PSHS D
+ LBRA NEXT
+* LDX RP
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* PULS A ;
+* PULS B ;
+* STA 2,X
+* STB 3,X
+* JMP NEXT
+*
+* ======>> 29 <<
+* ( --- n )
+* ( n *** )
+* Move top of return stack to top of parameter stack.
+ FCB $82
+ FCC 'R' ; 'R>'
+ FCB $BE
+ FDB TOR-5
+FROMR FDB *+NATWID
+ PULS D
+ PSHU D
+ LBRA NEXT
+* LDX RP
+* LDA 2,X
+* LDB 3,X
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX RP
+* JMP PUSHBA
+*
+* ======>> 30 <<
+* ( --- n )
+* ( n *** n )
+* Copy the top of return stack to top of parameter stack.
+* A synonym for I.
+ FCB $81 R
+ FCB $D2
+ FDB FROMR-5
+R FDB I+NATWID
+
+* LDX RP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* JMP GETX
+*
+* ######>> screen 28 <<
+* ======>> 31 <<
+* ( n --- ~n )
+* Logically invert top of stack;
+* or flag true if top is zero, otherwise false.
+ FCB $83
+ FCC 'NO' ; 'NOT'
+ FCB $D4
+ FDB R-4
+LNOT FDB *+NATWID
+ COM 1,U
+ COM ,U
+ LBRA NEXT
+* ( n --- n=0 )
+* Logically invert top of stack;
+* or flag true if top is zero, otherwise false.
+ FCB $82
+ FCC '0' ; '0='
+ FCB $BD
+ FDB LNOT-6
+ZEQU FDB *+NATWID
+ LDD #0
+ LDX ,U
+ BNE ZEQUF
+ INCB ; 1 is true
+ZEQUF STD ,U
+ LBRA NEXT
+* TFR S,X ; TSX :
+* CLRA ;
+* CLRB ;
+* LDX 0,X
+* BNE ZEQU2
+* INCB ;
+*ZEQU2 TFR S,X ; TSX :
+* JMP STABX
+*
+* ======>> 32 <<
+* ( n --- n<0 )
+* Flag true if top is negative (MSbit set), otherwise false.
+ FCB $82
+ FCC '0' ; '0<'
+ FCB $BC
+ FDB ZEQU-5
+ZLESS FDB *+NATWID
+ LDD #0
+ TST ,U
+ BPL ZLESSF
+ INCB
+ZLESSF STD ,U
+ LBRA NEXT
+* TFR S,X ; TSX :
+* LDA #$80 check the sign bit
+* ANDA 0,X
+* BEQ ZLESS2
+* CLRA ; if neg.
+* LDB #1
+* JMP STABX
+* ZLESS2 CLRB ;
+* JMP STABX
+*
+* ######>> screen 29 <<
+* ======>> 33 <<
+* ( n1 n2 --- n1+n2 )
+* Add top two words.
+ FCB $81 '+'
+ FCB $AB
+ FDB ZLESS-5
+PLUS FDB *+NATWID
+ PULU A,B ; #2~7
+ ADDD ,U ; #2~6
+ STD ,U ; #2~5
+ LBRA NEXT ; #1~5 =#7~23
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* ADDB 1,X
+* ADCA 0,X
+* JMP STABX
+*
+* ======>> 34 <<
+* ( d1 d2 --- d1+d2 )
+* Add top two double integers.
+ FCB $82
+ FCC 'D' ; 'D+'
+ FCB $AB
+ FDB PLUS-4
+DPLUS FDB *+NATWID
+ LDD 3*NATWID,U
+ ADDD NATWID,U
+ STD 3*NATWID,U
+ LDD 2*NATWID,U
+ ADCB 1,U
+ ADCA ,U
+ LEAU 2*NATWID,U
+ STD ,U
+ LBRA NEXT
+* TFR S,X ; TSX :
+* ANDCC #~$01 ; CLC :
+* LDB #4
+* DPLUS2 LDA 3,X
+* ADCA 7,X
+* STA 7,X
+* LEAX -1,X ;
+* DECB ;
+* BNE DPLUS2
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP NEXT
+*
+* ======>> 35 <<
+* ( n --- -n )
+* Negate (two's complement) top of stack.
+ FCB $85
+ FCC 'MINU' ; 'MINUS'
+ FCB $D3
+ FDB DPLUS-5
+MINUS FDB *+NATWID
+ LDD #0 ; #3~3
+ SUBD ,U ; #2~5
+ STD ,U ; #2~5
+ LBRA NEXT ; #1~5 = #8~18
+*
+* from 6800 model code:
+* TFR S,X ; TSX :
+* NEG 1,X
+* BCC MINUS2
+* NEG 0,X
+* BRA MINUS3
+* MINUS2 COM 0,X
+* MINUS3 JMP NEXT
+*
+* ======>> 36 <<
+* ( d --- -d )
+* Negate (two's complement) top two words on stack as a double integer.
+ FCB $86
+ FCC 'DMINU' ; 'DMINUS'
+ FCB $D3
+ FDB MINUS-8
+DMINUS FDB *+NATWID
+ LDD #0 ; #3~3
+ SUBD NATWID,U ; #2~7
+ STD NATWID,U ; #2~7
+ LDD #0 ; #3~3
+ SBCB 1,U ; #2~5
+ SBCA ,U ; #2~4
+ STD ,U ; #2~5
+ LBRA NEXT ; #1~5 = #17~39
+* TFR S,X ; TSX :
+* COM 0,X
+* COM 1,X
+* COM 2,X
+* NEG 3,X
+* BNE DMINX
+* INC 2,X
+* BNE DMINX
+* INC 1,X
+* BNE DMINX
+* INC 0,X
+* DMINX JMP NEXT
+*
+* ######>> screen 30 <<
+* ======>> 37 <<
+* ( n1 n2 --- n1 n2 n1 )
+* Push a copy of the second word on stack.
+ FCB $84
+ FCC 'OVE' ; 'OVER'
+ FCB $D2
+ FDB DMINUS-9
+OVER FDB *+NATWID
+ LDD NATWID,U
+ PSHU D
+ LBRA NEXT
+* TFR S,X ; TSX :
+* LDA 2,X
+* LDB 3,X
+* JMP PUSHBA
+*
+* ======>> 38 <<
+* ( n --- )
+* Discard the top word on stack.
+ FCB $84
+ FCC 'DRO' ; 'DROP'
+ FCB $D0
+ FDB OVER-7
+DROP FDB *+NATWID
+ LEAU NATWID,U
+ LBRA NEXT
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP NEXT
+*
+* ======>> 39 <<
+* ( n1 n2 --- n2 n1 )
+* Swap the top two words on stack.
+ FCB $84
+ FCC 'SWA' ; 'SWAP'
+ FCB $D0
+ FDB DROP-7
+SWAP FDB *+NATWID
+ PULU D,X
+ PSHU D
+ PSHU X
+ LBRA NEXT
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* LDX 0,X
+* LEAS 1,S ;
+* LEAS 1,S ;
+* PSHS B ;
+* PSHS A ;
+* STX N
+* LDX #N
+* JMP GETX
+*
+* ======>> 40 <<
+* ( n1 --- n1 n1 )
+* Push a copy of the top word on stack.
+ FCB $83
+ FCC 'DU' ; 'DUP'
+ FCB $D0
+ FDB SWAP-7
+DUP FDB *+NATWID
+ LDD ,U
+ PSHU D
+ LBRA NEXT
+* PULS A ;
+* PULS B ;
+* PSHS B ;
+* PSHS A ;
+* JMP PUSHBA
+*
+* ######>> screen 31 <<
+* ======>> 41 <<
+* ( n adr --- )
+* Add the second word on stack to the word at the adr on top of stack.
+ FCB $82
+ FCC '+' ; '+!'
+ FCB $A1
+ FDB DUP-6
+PSTORE FDB *+NATWID
+ PULU X
+ LDD ,X
+ ADDD ,U++
+ STD ,X
+ LBRA NEXT
+* TFR S,X ; TSX :
+* LDX 0,X
+* LEAS 1,S ;
+* LEAS 1,S ;
+* PULS A ; get stack data
+* PULS B ;
+* ADDB 1,X add & store low byte
+* STB 1,X
+* ADCA 0,X add & store hi byte
+* STA 0,X
+* JMP NEXT
+*
+* ======>> 42 <<
+* ( adr b --- )
+* Exclusive or byte at adr with low byte of top word.
+ FCB $86
+ FCC 'TOGGL' ; 'TOGGLE'
+ FCB $C5
+ FDB PSTORE-5
+TOGGLE FDB *+NATWID
+ PULU D,X
+ EORB ,X
+ STB ,X
+ LBRA NEXT
+* Using the model code would be less likely to introduce bugs,
+* but that would sort-of defeat my purposes here.
+* Anyway, I can borrow from theoretically known good bif-6809 code
+* and it's fewer bytes and much faster code this way.
+* TOGGLE
+* FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
+* FDB SEMIS
+*
+* ######>> screen 32 <<
+* ======>> 43 <<
+* ( adr --- n )
+* Replace address on stack with the word at the address.
+ FCB $81 @
+ FCB $C0
+ FDB TOGGLE-9
+AT FDB *+NATWID
+ LDD [,U]
+ STD ,U
+ LBRA NEXT
+* TFR S,X ; TSX :
+* LDX 0,X get address
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP GETX
+*
+* ======>> 44 <<
+* ( adr --- b )
+* Replace address on top of stack with the byte at the address.
+* High byte of result is clear.
+ FCB $82
+ FCC 'C' ; 'C@'
+ FCB $C0
+ FDB AT-4
+CAT FDB *+NATWID
+ LDB [,U]
+ CLRA
+ STD ,U
+ LBRA NEXT
+
+
+* TFR S,X ; TSX :
+* LDX 0,X
+* CLRA ;
+* LDB 0,X
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP PUSHBA
+*
+* ======>> 45 <<
+* ( n adr --- )
+* Store second word on stack at address on top of stack.
+ FCB $81
+ FCB $A1
+ FDB CAT-5
+STORE FDB *+NATWID
+ LDD NATWID,U
+ STD [,U]
+ LEAU 2*NATWID,U
+ LBRA NEXT
+* TFR S,X ; TSX :
+* LDX 0,X get address
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP PULABX
+*
+* ======>> 46 <<
+* ( b adr --- )
+* Store low byte of second word on stack at address on top of stack.
+* High byte is ignored.
+ FCB $82
+ FCC 'C' ; 'C!'
+ FCB $A1
+ FDB STORE-4
+CSTORE FDB *+NATWID
+ LDB 3,U
+ STB [,U]
+ LEAU 2*NATWID,U
+ LBRA NEXT
+* TFR S,X ; TSX :
+* LDX 0,X get address
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* PULS B ;
+* STB 0,X
+* JMP NEXT
+ PAGE
+*
+* ######>> screen 33 <<
+* ======>> 47 <<
+* ( --- ) P
+* { : name sundry-activities ; } typical input
+* If executing (not compiling),
+* record the data stack mark in CSP,
+* Set the CONTEXT vocabulary to CURRENT,
+* CREATE a header,
+* set state to compile,
+* and compile the call to the trailing native CPU machine code DOCOL.
+*
+* This would not be hard to flatten to native code.
+* But that's not the purpose of a model.
+ FCB $C1 : immediate
+ FCB $BA
+ FDB CSTORE-5
+COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
+ FDB CREATE,RBRAK
+ FDB PSCODE
+
+* Here is the IP pusher for allowing
+* nested words in the virtual machine:
+* ( ;S is the equivalent un-nester )
+
+* ( *** oldIP )
+* Characteristic of a colon (:) definition.
+* Begins execution of a high-level definition,
+* i. e., nests the definition and begins processing icodes.
+* Mechanically, it pushes the IP (Y register)
+* and loads the Parameter Field Address of the definition which
+* called it into the IP.
+DOCOL PSHS Y ; Nest the old IP.
+ LEAY NATWID,X ; W still in X, bump to parameters, load as new IP.
+ LBRA NEXT ; No return, just jump.
+
+* DOCOL LDX RP make room in the stack
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* LDA IP
+* LDB IP+1
+* STA 2,X Store address of the high level word
+* STB 3,X that we are starting to execute
+* LDX W Get first sub-word of that definition
+* JMP NEXT+2 and execute it
+*
+* ======>> 48 <<
+* ( --- ) P
+* { : name sundry-activities ; } typical input
+* ERROR check data stack against mark in CSP,
+* compile ;S,
+* unSMUDGE LATEST definition,
+* and set state to interpretation.
+ FCB $C1 ; imnediate code
+ FCB $BB
+ FDB COLON-4
+SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
+ FDB SEMIS
+*
+* ######>> screen 34 <<
+* ======>> 49 <<
+* ( n --- )
+* { value CONSTANT name } typical input
+* CREATE a header,
+* unSMUDGE it,
+* compile the constant value,
+* and compile the call to the trailing native CPU machine code DOCON.
+ FCB $88
+ FCC 'CONSTAN' ; 'CONSTANT'
+ FCB $D4
+ FDB SEMI-4
+CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
+* ( --- n )
+* Characteristic of a CONSTANT.
+* A CONSTANT simply loads its value from its parameter field
+* and pushes it on the stack.
+DOCON LDD NATWID,X ; Get the first natural width word of the parameter field.
+ PSHU D
+ LBRA NEXT
+* 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
+ LBRA NEXT
+* How this might have been done for 6800 model:
+* CLRA ; We know the natural width is less than 255, LOL.
+* LDAB NATWCV+1
+* TSX
+* ADDB 1,X
+* ADCA ,X
+* JMP STABX
+*
+* ======>> 50 <<
+* ( init --- )
+* { init VARIABLE name } typical input
+* Use CONSTANT to CREATE a header and compile the initial value, init,
+* then overwrite the characteristic to point to DOVAR.
+ FCB $88
+ FCC 'VARIABL' ; 'VARIABLE'
+ FCB $C5
+ FDB NATP-7
+VAR FDB DOCOL,CON,PSCODE
+* ( --- vadr )
+* Characteristic of a VARIABLE.
+* A VARIABLE pushes its PFA address on the stack.
+* The parameter field of a VARIABLE is the actual allocation of the variable,
+* so that pushing its address allows its contents to be @ed (fetched).
+* Ordinary arrays and strings that do not subscript themselves
+* may be allocated by defining a variable
+* and immediately ALLOTting the remaining needed space.
+* VARIABLES are global to all users,
+* and thus should be hidden in resource monitors, but aren't.
+DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters.
+ PSHU X
+ LBRA NEXT
+* DOVAR LDA W
+* LDB W+1
+* ADDB #2
+* ADCA #0 A,B now contain the address of the variable
+* JMP PUSHBA
+*
+* ======>> 51 <<
+* ( ub --- )
+* { uboffset USER name } typical input
+* CREATE a header and compile the unsigned byte offset in the per-USER table,
+* then overwrite the header with a call to DOUSER.
+* The USER is entirely responsible for maintaining allocation!
+ FCB $84
+ FCC 'USE' ; 'USER'
+ FCB $D2
+ FDB VAR-11
+USER FDB DOCOL,CON,PSCODE
+* ( --- vadr )
+* Characteristic of a per-USER variable.
+* USER variables are similiar to VARIABLEs,
+* but are allocated (by hand!) in the per-user table.
+* A USER variable's parameter field contains its offset in the per-user table.
+DOUSER TFR DP,A ; Make a pointer to the direct page.
+ CLRB
+* See Alternative -- alternatives start from this point.
+ ADDD NATWID,X ; Add it to the offset to the per-user variable.
+ PSHU D
+ TFR D,X ; Cache the pointer in X for the caller.
+ LBRA NEXT
+* 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
+* LBRA NEXT
+* Alternative B:
+* PSHS Y ; Get Y free for calculations.
+* TFR D,Y ; Y points to the UP base
+* LDD NATWID,X ; Get the offset
+* LEAX D,Y ; Leave the pointer cached in X.
+* PSHU X
+* PULS Y,PC
+*
+* From the 6800 model:
+* DOUSER LDX W get offset into user's table
+* LDA 2,X
+* LDB 3,X
+* ADDB UP+1 add to users base address
+* ADCA UP
+* JMP PUSHBA push address of user's variable
+*
+* ######>> screen 35 <<
+* ======>> 52 <<
+* ( --- 0 )
+ FCB $81
+ FCB $B0 0
+ FDB USER-7
+ZERO FDB DOCON
+ FDB 0000
+*
+* ======>> 53 <<
+* ( --- 1 )
+ FCB $81
+ FCB $B1 1
+ FDB ZERO-4
+ONE FDB DOCON
+ONEV FDB 1
+*
+* ======>> 54 <<
+* ( --- 2 )
+ FCB $81
+ FCB $B2 2
+ FDB ONE-4
+TWO FDB DOCON
+TWOV FDB 2
+*
+* ======>> 55 <<
+* ( --- 3 )
+ FCB $81
+ FCB $B3 3
+ FDB TWO-4
+THREE FDB DOCON
+ FDB 3
+*
+* ======>> 56 <<
+* ( --- SP )
+* ASCII SPACE character
+ FCB $82
+ FCC 'B' ; 'BL'
+ FCB $CC
+ FDB THREE-4
+BL FDB DOCON ascii blank
+ FDB $20
+*
+* ======>> 57 <<
+* This really shouldn't be a CONSTANT.
+* ( --- adr )
+* The base of the disk buffer space.
+ FCB $85
+ FCC 'FIRS' ; 'FIRST'
+ FCB $D4
+ FDB BL-5
+FIRST FDB DOCON
+ FDB BUFBAS
+* FDB MEMEND-528 (132 * NBLK)
+*
+* ======>> 58 <<
+* This really shouldn't be a CONSTANT.
+* ( --- adr )
+* The limit of the disk buffer space.
+ FCB $85
+ FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
+ FCB $D4
+ FDB FIRST-8
+LIMIT FDB DOCON
+ FDB BUFBAS+BUFSZ
+* In 6800 model, was
+* FDB MEMEND
+*
+* ======>> 59 <<
+* ( --- sectorsize )
+* The size, in bytes, of a buffer control region.
+ FCB $85
+ FCC 'B/CT' ; 'B/CTL' : (bytes/control region)
+ FCB $CC
+ FDB LIMIT-8
+BCTL FDB DOCON
+ FDB SECTRL
+*
+* ( --- sectorsize )
+* The size, in bytes, of a buffer.
+ FCB $85
+ FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
+ FCB $C6
+ FDB BCTL-8
+BBUF FDB DOCON
+ FDB SECTSZ
+* Hardcoded in 6800 model:
+* FDB 128
+*
+* ======>> 60 <<
+* ( --- blocksperscreen )
+* The size, in blocks, of a screen.
+* Should this be the same as NBLK, the number of block buffers maintained?
+ FCB $85
+ FCC 'B/SC' ; 'B/SCR' : (blocks/screen)
+ FCB $D2
+ FDB BBUF-8
+BSCR FDB DOCON
+ FDB SCRSZ/SECTSZ
+* Hardcoded in 6800 model as:
+* FDB 8
+* blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
+*
+* ======>> 61 <<
+* ( n --- adr )
+* Calculate the address of entry (#n/2) in the boot-up parameter table.
+* (Adds the base of the boot-up table to n.)
+ FCB $87
+ FCC '+ORIGI' ; '+ORIGIN'
+ FCB $CE
+ FDB BSCR-8
+PORIG FDB DOCOL,LIT,ORIG,PLUS
+ FDB SEMIS
+*
+* ######>> screen 36 <<
+* ======>> 62 <<
+* ( n --- adr )
+* This is the per-task variable recording the initial parameter stack pointer.
+ FCB $82
+ FCC 'S' ; 'S0'
+ FCB $B0
+ FDB PORIG-10
+SZERO FDB DOUSER
+ FDB XSPZER-UORIG
+*
+* ======>> 63 <<
+* ( n --- adr )
+* This is the per-task variable recording the initial return stack pointer.
+ FCB $82
+ FCC 'R' ; 'R0'
+ FCB $B0
+ FDB SZERO-5
+RZERO FDB DOUSER
+ FDB XRZERO-UORIG
+*
+* ======>> 64 <<
+* ( --- vadr )
+* Terminal Input Buffer address.
+* Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
+ FCB $83
+ FCC 'TI' ; 'TIB'
+ FCB $C2
+ FDB RZERO-5
+TIB FDB DOUSER
+ FDB XTIB-UORIG
+*
+* ======>> 65 <<
+* ( --- maxnamewidth )
+* This is the maximum width to which symbol names will be recorded.
+ FCB $85
+ FCC 'WIDT' ; 'WIDTH'
+ FCB $C8
+ FDB TIB-6
+WIDTH FDB DOUSER
+ FDB XWIDTH-UORIG
+*
+* ======>> 66 <<
+* ( --- vadr )
+* Availability of error messages on disk.
+* Contains 1 if messages available,
+* 0 if not,
+* -1 if a disk error has occurred.
+ FCB $87
+ FCC 'WARNIN' ; 'WARNING'
+ FCB $C7
+ FDB WIDTH-8
+WARN FDB DOUSER
+ FDB XWARN-UORIG
+*
+* ======>> 67 <<
+* ( --- vadr )
+* Boundary for FORGET.
+ FCB $85
+ FCC 'FENC' ; 'FENCE'
+ FCB $C5
+ FDB WARN-10
+FENCE FDB DOUSER
+ FDB XFENCE-UORIG
+*
+* ======>> 68 <<
+* ( --- vadr )
+* Dictionary pointer, fetched by HERE.
+ FCB $82
+ FCC 'D' ; 'DP' : points to first free byte at end of dictionary
+ FCB $D0
+ FDB FENCE-8
+DICTPT FDB DOUSER
+ FDB XDICTP-UORIG
+*
+* ======>> 68.5 <<
+* ( --- vadr ) ******* Need to check what this is!
+* Used in maintaining vocabularies.
+* I think it points to the "parent" vocabulary, but I'm not sure.
+* Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
+ FCB $88
+ FCC 'VOC-LIN' ; 'VOC-LINK'
+ FCB $CB
+ FDB DICTPT-5
+VOCLIN FDB DOUSER
+ FDB XVOCL-UORIG
+*
+* ======>> 69 <<
+* ( --- vadr )
+* Disk block being interpreted.
+* Zero refers to terminal.
+* ******** Should be made a 32 bit user variable! ********
+* But the base system needs to have full 32 bit support, div and mul, etc.
+* before we can do that.
+ FCB $83
+ FCC 'BL' ; 'BLK'
+ FCB $CB
+ FDB VOCLIN-11
+BLK FDB DOUSER
+ FDB XBLK-UORIG
+*
+* ======>> 70 <<
+* ( --- vadr )
+* Input buffer offset/cursor.
+ FCB $82
+ FCC 'I' ; 'IN' : scan pointer for input line buffer
+ FCB $CE
+ FDB BLK-6
+IN FDB DOUSER
+ FDB XIN-UORIG
+*
+* ======>> 71 <<
+* ( --- vadr )
+* Output buffer offset/cursor.
+ FCB $83
+ FCC 'OU' ; 'OUT'
+ FCB $D4
+ FDB IN-5
+OUT FDB DOUSER
+ FDB XOUT-UORIG
+*
+* ======>> 72 <<
+* ( --- vadr )
+* Screen currently being edited, once we have an editor running.
+ FCB $83
+ FCC 'SC' ; 'SCR'
+ FCB $D2
+ FDB OUT-6
+SCR FDB DOUSER
+ FDB XSCR-UORIG
+* ######>> screen 37 <<
+*
+* ======>> 73 <<
+* ( --- vadr )
+* Sector offset for LOADing screens,
+* set by DRIVE to make a new drive the default.
+* This should also be 32 bit or bigger.
+ FCB $86
+ FCC 'OFFSE' ; 'OFFSET'
+ FCB $D4
+ FDB SCR-6
+OFSET FDB DOUSER
+ FDB XOFSET-UORIG
+*
+* ======>> 74 <<
+* ( --- vadr )
+* Current context of interpretation (vocabulary root).
+ FCB $87
+ FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
+ FCB $D4
+ FDB OFSET-9
+CONTXT FDB DOUSER
+ FDB XCONT-UORIG
+*
+* ======>> 75 <<
+* ( --- vadr )
+* Current context of definition (vocabulary root).
+ FCB $87
+ FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
+ FCB $D4
+ FDB CONTXT-10
+CURENT FDB DOUSER
+ FDB XCURR-UORIG
+*
+* ======>> 76 <<
+* ( --- vadr )
+* Compiler/interpreter state.
+ FCB $85
+ FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
+ FCB $C5
+ FDB CURENT-10
+STATE FDB DOUSER
+ FDB XSTATE-UORIG
+*
+* ======>> 77 <<
+* ( --- vadr )
+* Numeric conversion base.
+ FCB $84
+ FCC 'BAS' ; 'BASE' : number base for all input & output
+ FCB $C5
+ FDB STATE-8
+BASE FDB DOUSER
+ FDB XBASE-UORIG
+*
+* ======>> 78 <<
+* ( --- vadr )
+* Decimal point location for output.
+ FCB $83
+ FCC 'DP' ; 'DPL'
+ FCB $CC
+ FDB BASE-7
+DPL FDB DOUSER
+ FDB XDPL-UORIG
+*
+* ======>> 79 <<
+* ( --- vadr )
+* Field width for I/O formatting.
+ FCB $83
+ FCC 'FL' ; 'FLD'
+ FCB $C4
+ FDB DPL-6
+FLD FDB DOUSER
+ FDB XFLD-UORIG
+*
+* ======>> 80 <<
+* ( --- vadr )
+* Compiler stack mark for stack check.
+ FCB $83
+ FCC 'CS' ; 'CSP'
+ FCB $D0
+ FDB FLD-6
+CSP FDB DOUSER
+ FDB XCSP-UORIG
+*
+* ======>> 81 <<
+* ( --- vadr )
+* Editing cursor location.
+ FCB $82
+ FCC 'R' ; 'R#'
+ FCB $A3
+ FDB CSP-6
+RNUM FDB DOUSER
+ FDB XRNUM-UORIG
+*
+* ======>> 82 <<
+* ( --- vadr )
+* Pointer to last HELD character in PAD.
+ FCB $83
+ FCC 'HL' ; 'HLD'
+ FCB $C4
+ FDB RNUM-5
+HLD FDB DOCON
+ FDB XHLD
+*
+* ======>> 82.5 <<== SPECIAL
+* ( --- vadr )
+* Line width of active terminal.
+ FCB $87
+ FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
+ FCB $D3
+ FDB HLD-6
+COLUMS FDB DOUSER
+ FDB XCOLUM-UORIG
+*
+* ######>> screen 38 <<
+**
+** An INCREMENTER probably should not be defined without a defined CONSTANT?
+**
+** Make an INCREMENTER compiling word (not in model):
+** ( n --- )
+** { n INCREMENTER name } typical input
+** CREATE a header and compile the increment constant,
+** then overwrite the header with a call to DOINC.
+* FCB $8B
+* FCC 'INCREMENTE' ; 'INCREMENTER'
+* FCB $D2
+* FDB COLUMS-10
+* INCR FDB DOCOL,CON,PSCODE
+** ( n --- ninc )
+** Characteristic of an INCREMENTER.
+** This is too naive:
+* DOINC LDD ,U
+* ADDD NATWID,X ; Add the increment.
+* STD ,U
+* LBRA NEXT
+* 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
+* LBRA NEXT
+* 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
+* LBRA NEXT
+*
+* ======>> 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
+* LBRA NEXT
+* Naive alternative:
+* TWOP FDB DOINC
+* FDB 2
+* Naive alternative:
+* TWOP FDB *+NATWID
+* LDD ,U
+* ADDD #2 ; See NAT+ (NATP)
+* STD ,U
+* LBRA NEXT
+*
+* ======>> 85 <<
+* ( --- adr )
+* Get the DICTPT allocation, like a USER constant.
+* Should check the stack and heap for collision.
+ FCB $84
+ FCC 'HER' ; 'HERE'
+ FCB $C5
+ FDB TWOP-5
+HERE FDB DOCOL,DICTPT,AT
+ FDB SEMIS
+*
+* ======>> 86 <<
+* ( n --- )
+* Increase/decrease heap (add n to DP),
+* Should ERROR check stack/heap.
+ FCB $85
+ FCC 'ALLO' ; 'ALLOT'
+ FCB $D4
+ FDB HERE-7
+ALLOT FDB DOCOL,DICTPT,PSTORE
+ FDB SEMIS
+*
+* ======>> 87 <<
+* ( n --- )
+* Store word n at DP++,
+* Should ERROR check stack/heap.
+ FCB $81 ; , (COMMA)
+ FCB $AC
+ FDB ALLOT-8
+COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT
+ FDB SEMIS
+* COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
+* FDB SEMIS
+*
+* ======>> 88 <<
+* ( b --- )
+* Store byte b at DP+,
+* Should ERROR check stack/heap.
+ FCB $82
+ FCC 'C' ; 'C,'
+ FCB $AC
+ FDB COMMA-4
+CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
+ FDB SEMIS
+*
+* ======>> 89 <<
+* ( n1 n2 --- n1-n2 )
+* Subtract top two words.
+ FCB $81 ; -
+ FCB $AD
+ FDB CCOMM-5
+SUB FDB *+NATWID
+ LDD NATWID,U ; #2~6
+ SUBD ,U++ ; #2~9
+ STD ,U ; #2~5
+ LBRA NEXT ; #1~5 = #7~25
+* SUB FDB DOCOL,MINUS,PLUS
+* FDB SEMIS ; Costs 6 bytes and lots of cycles.
+*
+* ======>> 90 <<
+* ( n1 n2 --- n1==n2 )
+* Return flag true if n1 and n2 are equal, otherwise false.
+ FCB $81 =
+ FCB $BD
+ FDB SUB-4
+EQUAL FDB DOCOL,SUB,ZEQU
+ FDB SEMIS
+*
+* ======>> 91 <<
+* ( n1 n2 --- n1<n2 )
+* Return flag true if n1 is less than n2, otherwise false.
+ FCB $81 <
+ FCB $BC
+ FDB EQUAL-4
+LESS FDB *+NATWID
+ LDD NATWID,U
+ SUBD ,U++
+ BGE FALSE
+TRUE LDD #1
+ STD ,U
+ LBRA NEXT
+FALSE LDD #0
+ STD ,U
+ LBRA NEXT
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* CMPA 0,X
+* LEAS 1,S ;
+* BGT LESST
+* BNE LESSF
+* CMPB 1,X ; Why not sub, sbc, bge?
+* BHI LESST
+* LESSF CLRB ;
+* BRA LESSX
+* LESST LDB #1
+* LESSX CLRA ;
+* LEAS 1,S ;
+* JMP PUSHBA
+*
+* ======>> 92 <<
+* ( n1 n2 --- n1>n2 )
+* Return flag true if n1 is greater than n2, false otherwise.
+ FCB $81 >
+ FCB $BE
+ FDB LESS-4
+GREAT FDB DOCOL,SWAP,LESS
+ FDB SEMIS
+*
+* ======>> 93 <<
+* ( n1 n2 n3 --- n2 n3 n1 )
+* Rotate the top three words on stack,
+* bringing the third word to the top.
+ FCB $83
+ FCC 'RO' ; 'ROT'
+ FCB $D4
+ FDB GREAT-4
+ROT FDB *+NATWID
+ PSHS Y
+ PULU D,X,Y
+ PSHU D,X
+ PSHU Y
+ PULS Y
+ LBRA NEXT
+* ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
+* FDB SEMIS
+*
+* ======>> 94 <<
+* ( --- )
+* EMIT a SPACE.
+ FCB $85
+ FCC 'SPAC' ; 'SPACE'
+ FCB $C5
+ FDB ROT-6
+SPACE FDB DOCOL,BL,EMIT
+ FDB SEMIS
+*
+* ======>> 95 <<
+* ( n0 n1 --- min(n0,n1) )
+* Leave the minimum of the top two integers.
+* Being too greedy here, but, whatever.
+ FCB $83
+ FCC 'MI' ; 'MIN'
+ FCB $CE
+ FDB SPACE-8
+MIN FDB *+NATWID
+ PULU D
+ CMPD ,U
+ BLE MINX
+ STD ,U
+MINX LBRA NEXT
+* MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
+* FDB MIN2-*-NATWID
+* FDB SWAP
+* MIN2 FDB DROP
+* FDB SEMIS
+*
+* ======>> 96 <<
+* ( n0 n1 --- max(n0,n1) )
+* Leave the maximum of the top two integers.
+* Really should leave this as in the model.
+ FCB $83
+ FCC 'MA' ; 'MAX'
+ FCB $D8
+ FDB MIN-6
+MAX FDB *+NATWID
+ PULU D
+ CMPD ,U
+ BLE MAXX
+ STD ,U
+MAXX LBRA NEXT
+* MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
+* FDB MAX2-*-NATWID
+* FDB SWAP
+* MAX2 FDB DROP
+* FDB SEMIS
+*
+* ======>> 97 <<
+* ( 0 --- 0 )
+* ( n --- n n )
+* DUP if non-zero.
+ FCB $84
+ FCC '-DU' ; '-DUP'
+ FCB $D0
+ FDB MAX-6
+DDUP FDB *+NATWID ; Just being greedy for speed.
+ LDD ,U
+ BEQ DDUPX
+ PSHU D
+DDUPX LBRA NEXT
+* 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?
+ LBRA NEXT
+* 6800 model version should be something like this:
+* LDB #1
+* CLRA
+* TSX
+* TST ,X
+* BPL SIGNUP
+* NEGB
+* COMA
+* SIGNUP JMP STABX
+*
+* ======>> 98 <<
+* ( adr1 direction --- adr2 )
+* TRAVERSE the symbol name.
+* If direction is 1, find the end.
+* If direction is -1, find the beginning.
+ FCB $88
+ FCC 'TRAVERS' ; 'TRAVERSE'
+ FCB $C5
+ FDB SIGNUM-9
+* TRAV FDB *+NATWID
+* BSR SIGNUE ; Convert negative to -, zero or positive to 1.
+* LDD ,U++ ; Still in D, but we have to pop it anyway.
+* LDX ,U ; If D is 1 or -1, so is B.
+* LDA #$7F
+* TRAVLP LEAX B,X ; Don't look at the one we start at.
+* CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL.
+* BCC TRAVLP
+* TRAVDN STX ,U
+* LBRA NEXT
+* Doing this in 6809 just because it can be done was 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.
+* LBRA NEXT
+* Version 2:
+* LEAX CURENT,PCR
+* JSR [,X]
+* PULU X
+* LDX [,X]
+* PSHU X
+* LBRA NEXT
+* Too greedy, too many smantic holes to fall through.
+* If the address at the CFA is made relative,
+* this is part of the code that would be affected
+* if it is in native CPU code.
+*
+* ======>> 100 <<
+* Wanted to do these as INCREMENTERs,
+* but I need to stick with the model as much as possible,
+* (mostly, LOL) adding code only to make the model more clear.
+* ( pfa --- lfa )
+* Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
+ FCB $83
+ FCC 'LF' ; 'LFA'
+ FCB $C1
+ FDB LATEST-9
+LFA FDB DOCOL,LIT8
+* FCB 4
+ FCB 2*NATWID
+ FDB SUB
+ FDB SEMIS
+*
+* ======>> 101 <<
+* ( pfa --- cfa )
+* Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
+ FCB $83
+ FCC 'CF' ; 'CFA'
+ FCB $C1
+ FDB LFA-6
+* CFA FDB DOCOL,TWO,SUB
+CFA FDB DOCOL,NATWC,SUB
+ FDB SEMIS
+*
+* ======>> 102 <<
+* ( pfa --- nfa )
+* Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
+ FCB $83
+ FCC 'NF' ; 'NFA'
+ FCB $C1
+ FDB CFA-6
+NFA FDB DOCOL,LIT8
+* FCB 5
+ FCB NATWID*2+1
+ FDB SUB,ONE,MINUS,TRAV
+ FDB SEMIS
+*
+* ======>> 103 <<
+* ( nfa --- pfa )
+* Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
+ FCB $83
+ FCC 'PF' ; 'PFA'
+ FCB $C1
+ FDB NFA-6
+PFA FDB DOCOL,ONE,TRAV,LIT8
+* FCB 5
+ FCB NATWID*2+1
+ FDB PLUS
+ FDB SEMIS
+*
+* ######>> screen 40 <<
+* ======>> 104 <<
+* ( --- )
+* Save the parameter stack pointer in CSP for compiler checks.
+ FCB $84
+ FCC '!CS' ; '!CSP'
+ FCB $D0
+ FDB PFA-6
+SCSP FDB DOCOL,SPAT,CSP,STORE
+ FDB SEMIS
+*
+* ======>> 105 <<
+* ( 0 n --- ) ( *** )
+* ( true n --- IN BLK ) ( anything *** nothing )
+* If flag is false, do nothing.
+* If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
+* Leaves cursor position (IN)
+* and currently loading block number (BLK) on stack, for analysis.
+*
+* This one is too important to be high-level Forth codes.
+* When we have an error, we want to disturb as little as possible.
+* But fixing that cascades through ERROR and MESSAGE
+* into the disk block system.
+* And we aren't ready for that yet.
+ FCB $86
+ FCC '?ERRO' ; '?ERROR'
+ FCB $D2
+ FDB SCSP-7
+* QERR FDB *+NATWID
+* LDD NATWID,U
+* BNE QERROR
+* LEAU 2*NATWID,U
+* LBRA NEXT
+** this doesn't work anyway: QERROR LBRA ERROR
+QERR FDB DOCOL,SWAP,ZBRAN
+ FDB QERR2-*-NATWID
+ FDB ERROR,BRAN
+ FDB QERR3-*-NATWID
+QERR2 FDB DROP
+QERR3 FDB SEMIS
+*
+* ======>> 106 <<
+* STATE is compiling:
+* ( --- ) ( *** )
+* STATE is not compiling:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not compiling.
+ FCB $85
+ FCC '?COM' ; '?COMP'
+ FCB $D0
+ FDB QERR-9
+QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8
+ FCB $11
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 107 <<
+* STATE is executing:
+* ( --- ) ( *** )
+* STATE is not executing:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not executing.
+ FCB $85
+ FCC '?EXE' ; '?EXEC'
+ FCB $C3
+ FDB QCOMP-8
+QEXEC FDB DOCOL,STATE,AT,LIT8
+ FCB $12
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 108 <<
+* ( n1 n1 --- ) ( *** )
+* ( n1 n2 --- IN BLK ) ( anything *** nothing )
+* ERROR if top two are unequal.
+* MESSAGE says compiled conditionals do not match.
+ FCB $86
+ FCC '?PAIR' ; '?PAIRS'
+ FCB $D3
+ FDB QEXEC-8
+QPAIRS FDB DOCOL,SUB,LIT8
+ FCB $13
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 109 <<
+* CSP and parameter stack are balanced (equal):
+* ( --- ) ( *** )
+* CSP and parameter stack are not balanced (unequal):
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if return/control stack is not at same level as last !CSP.
+* Usually indicates that a definition has been left incomplete.
+ FCB $84
+ FCC '?CS' ; '?CSP'
+ FCB $D0
+ FDB QPAIRS-9
+QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8
+ FCB $14
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 110 <<
+* Active BLK input:
+* ( --- ) ( *** )
+* No active BLK input:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not loading, i. e., if BLK is zero.
+ FCB $88
+ FCC '?LOADIN' ; '?LOADING'
+ FCB $C7
+ FDB QCSP-7
+QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8
+ FCB $16
+ FDB QERR
+ FDB SEMIS
+*
+* ######>> screen 41 <<
+* ======>> 111 <<
+* ( --- )
+* Compile an in-line literal value from the instruction stream.
+ FCB $87
+ FCC 'COMPIL' ; 'COMPILE'
+ FCB $C5
+ FDB QLOAD-11
+* COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
+* COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
+COMPIL FDB DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
+ FDB SEMIS
+*
+* ======>> 112 <<
+* ( --- ) P
+* Clear the compile state bit(s) (shift to interpret).
+ FCB $C1 [ immediate
+ FCB $DB
+ FDB COMPIL-10
+LBRAK FDB DOCOL,ZERO,STATE,STORE
+ FDB SEMIS
+*
+* ======>> 113 <<
+*
+STCOMP EQU $C0
+* ( --- )
+* Set the compile state bit(s) (shift to compile).
+ FCB $81 ]
+ FCB $DD
+ FDB LBRAK-4
+RBRAK FDB DOCOL,LIT8
+ FCB STCOMP
+ FDB STATE,STORE
+ FDB SEMIS
+*
+* ======>> 114 <<
+* ( --- )
+* Toggle SMUDGE bit of LATEST definition header,
+* to hide it until defined or reveal it after definition.
+ FCB $86
+ FCC 'SMUDG' ; 'SMUDGE'
+ FCB $C5
+ FDB RBRAK-4
+SMUDGE FDB DOCOL,LATEST,LIT8
+ FCB FSMUDG
+ FDB TOGGLE
+ FDB SEMIS
+*
+* ======>> 115 <<
+* ( --- )
+* Set the conversion base to sixteen (b00010000).
+ FCB $83
+ FCC 'HE' ; 'HEX'
+ FCB $D8
+ FDB SMUDGE-9
+HEX FDB DOCOL
+ FDB LIT8
+ FCB 16 ; decimal sixteen
+ FDB BASE,STORE
+ FDB SEMIS
+*
+* ======>> 116 <<
+* ( --- )
+* Set the conversion base to ten (b00001010).
+ FCB $87
+ FCC 'DECIMA' ; 'DECIMAL'
+ FCB $CC
+ FDB HEX-6
+DEC FDB DOCOL
+ FDB LIT8
+ FCB 10 ; decimal ten
+ FDB BASE,STORE
+ FDB SEMIS
+*
+* ######>> screen 42 <<
+* ======>> 117 <<
+* ( --- ) ( IP *** )
+* Pop the saved IP and use it to
+* compile the latest symbol as a reference to a ;CODE definition;
+* overwrite the code field of the symbol found by LATEST
+* with the address of the low-level characteristic code
+* provided in the defining definition.
+* Look closely at where things return, consider the operation of R> and >R .
+*
+* The machine-level code which follows (;CODE) in the instruction stream
+* is not executed by the defining symbol,
+* but becomes the characteristic of the defined symbol.
+* This is the usual way to generate the characteristics of VARIABLEs,
+* CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
+*
+* Finally, note that, if code shifts from low level back to high
+* (native CPU machine code calling into a list of FORTH codes),
+* the low level code can't just call a high-level definition.
+* Leaf definitions can directly call other leaf definitions,
+* but not non-leafs.
+* It will need an anonymous list, probably embedded in the low-level code,
+* and Y and X will have to be set appropriately before entering the list.
+ FCB $87
+ FCC '(;CODE' ; '(;CODE)'
+ FCB $A9
+ FDB DEC-10
+* PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
+PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+ FDB LATEST,PFA,CFA,STORE
+ FDB SEMIS
+*
+* ======>> 118 <<
+* ( --- ) P
+* ?CSP to see if there are loose ends in the defining definition
+* before shifting to the assembler,
+* compile (;CODE) in the defining definition's instruction stream,
+* shift to interpreting,
+* make the ASSEMBLER vocabulary current,
+* and !CSP to mark the stack
+* in preparation for assembling low-level code.
+* Note that ;CODE, unlike DOES>, is IMMEDIATE,
+* and compiles (;CODE),
+* which will do the actual work of changing
+* the LATEST definition's characteristic when the defining word runs.
+* Assembly is done by the interpreter, rather than the compiler.
+* I could have avoided the anomalous three-byte code fields by
+*
+* Note that the ASSEMBLER is not part of the model (at this time).
+* That means that, until the assembler is ready,
+* if you want to define low-level words,
+* you have to poke (comma) in hand-assembled stuff.
+*
+ FCB $C5 immediate
+ FCC ';COD' ; ';CODE'
+ FCB $C5
+ FDB PSCODE-10
+SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
+ FDB SEMIS
+* note: "QSTACK" will be replaced by "ASSEMBLER" later
+*
+* ######>> screen 43 <<
+* ======>> 119 <<
+* ( --- ) C
+* Make the word currently being defined
+* build a header for DOES> definitions.
+* Actually just compiles a CONSTANT zero
+* which can be overwritten later by DOES>.
+* Since the fig models were established, this technique has been deprecated.
+*
+* Note that <BUILDS is not IMMEDIATE,
+* and therefore executes during a definition's run-time,
+* rather than its compile-time.
+* It is not intended to be used directly,
+* but rather so that one definition word can build another.
+* Also, note that nothing particularly special happens
+* in the defining definition until DOES> executes.
+* The name <BUILDS is intended to be a reminder of what is about to occur.
+*
+* <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
+ FCB $87
+ FCC '<BUILD' ; '<BUILDS'
+ FCB $D3
+ FDB SEMIC-8
+BUILDS FDB DOCOL,ZERO,CON
+ FDB SEMIS
+*
+* ======>> 120 <<
+* ( --- ) ( IP *** ) C
+* Define run-time behavior of definitions compiled/defined
+* by a high-level defining definition --
+* the FORTH equivalent of a compiler-compiler.
+* DOES> assumes that the LATEST symbol table entry
+* has at least one word of parameter field,
+* which <BUILDS provides.
+* Note that DOES> is also not IMMEDIATE.
+*
+* When the defining word containing DOES> executes the DOES> icode,
+* it overwrites the LATEST symbol's CFA with jsr <XDOES,
+* overwrites the first word of that symbol's parameter field with its own IP,
+* and pops the previous IP from the return stack.
+* The icodes which follow DOES> in the stream
+* do not execute at the defining word's run-time.
+*
+* Examining XDOES in the virtual machine shows
+* that the defined word will execute those icodes
+* which follow DOES> at its own run-time.
+*
+* The advantage of this kind of behaviour,
+* which you will also note in ;CODE,
+* is that the defined word can contain
+* both operations and data to be operated on.
+* This is how FORTH data objects define their own behavior.
+*
+* Finally, note that the effective parameter field for DOES> definitions
+* starts two NATWID words after the CFA, instead of just one
+* (four bytes instead of two in a sixteen-bit addressing Forth).
+*
+* VOCABULARYs will use this. See definition of word FORTH.
+ FCB $85
+ FCC 'DOES' ; 'DOES>'
+ FCB $BE
+ FDB BUILDS-10
+* DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
+DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+ FDB LATEST,PFA,STORE
+ FDB PSCODE
+*
+* ( --- PFA+NATWID ) ( *** IP )
+* Characteristic of a DOES> defined word.
+* The characteristics of DOES> definitions are written in high-level
+* Forth codes rather than native CPU machine level code.
+* The first parameter word points to the high-level characteristic.
+* This routine's job is to push the IP,
+* load the high level characteristic pointer in IP,
+* and leave the address following the characteristic pointer on the stack
+* so the parameter field can be accessed.
+DODOES PSHS Y ; 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
+ LBRA NEXT ; No return, just jump.
+*
+* From the 6800 model:
+* DODOES LDA IP
+* LDB IP+1
+* LDX RP make room on return stack
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* STA 2,X push return address
+* STB 3,X
+* LDX W get addr of pointer to run-time code
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX N stash it in scratch area
+* LDX 0,X get new IP
+* STX IP
+* CLRA ; get address of parameter
+* LDB #2
+* ADDB N+1
+* ADCA N
+* PSHS B ; and push it on data stack
+* PSHS A ;
+* JMP NEXT2
+*
+* ######>> screen 44 <<
+* ======>> 121 <<
+* ( strptr --- strptr+1 count )
+* Convert counted string to string and count.
+* (Fetch the byte at strptr, post-increment.)
+ FCB $85
+ FCC 'COUN' ; 'COUNT'
+ FCB $D4
+ FDB DOES-8
+COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
+ FDB SEMIS
+*
+* ======>> 122 <<
+* ( strptr count --- )
+* EMIT count characters at strptr.
+ FCB $84
+ FCC 'TYP' ; 'TYPE'
+ FCB $C5
+ FDB COUNT-8
+TYPE FDB DOCOL,DDUP,ZBRAN
+ FDB TYPE3-*-NATWID
+ FDB OVER,PLUS,SWAP,XDO
+TYPE2 FDB I,CAT,EMIT,XLOOP
+ FDB TYPE2-*-NATWID
+ FDB BRAN
+ FDB TYPE4-*-NATWID
+TYPE3 FDB DROP
+TYPE4 FDB SEMIS
+*
+* ======>> 123 <<
+* ( strptr count1 --- strptr count2 )
+* Supress trailing blanks (subtract count of trailing blanks from strptr).
+ FCB $89
+ FCC '-TRAILIN' ; '-TRAILING'
+ FCB $C7
+ FDB TYPE-7
+DTRAIL FDB DOCOL,DUP,ZERO,XDO
+DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
+ FDB SUB,ZBRAN
+ FDB DTRAL3-*-NATWID
+ FDB LEAVE,BRAN
+ FDB DTRAL4-*-NATWID
+DTRAL3 FDB ONE,SUB
+DTRAL4 FDB XLOOP
+ FDB DTRAL2-*-NATWID
+ FDB SEMIS
+*
+* ======>> 124 <<
+* ( --- )
+* TYPE counted string out of instruction stream (updating IP).
+ FCB $84
+ FCC '(."' ; '(.")'
+ FCB $A9
+ FDB DTRAIL-12
+* PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
+* PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
+PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP ; IP/Y is post-inc.
+ FDB FROMR,PLUS,TOR,TYPE
+ FDB SEMIS
+*
+* ======>> 125 <<
+* ( --- ) P
+* { ." something-to-be-printed " } typical input
+* Use WORD to parse to trailing quote;
+* if compiling, compile XDOTQ and string parsed,
+* otherwise, TYPE string.
+ FCB $C2 immediate
+ FCC '.' ; '."'
+ FCB $A2
+ FDB PDOTQ-7
+DOTQ FDB DOCOL
+ FDB LIT8
+ FCB $22 ascii quote
+ FDB STATE,AT,ZBRAN
+ FDB DOTQ1-*-NATWID
+ FDB COMPIL,PDOTQ,WORD
+ FDB HERE,CAT,ONEP,ALLOT,BRAN
+ FDB DOTQ2-*-NATWID
+DOTQ1 FDB WORD,HERE,COUNT,TYPE
+DOTQ2 FDB SEMIS
+*
+* ######>> screen 45 <<
+* ======>> 126 <<== MACHINE DEPENDENT
+* ( --- ) ( *** )
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if parameter stack out of bounds.
+*
+* But checking whether the stack is in bounds or not
+* really should not use the stack.
+* And there really should be a ?RSTACK, as well.
+ FCB $86
+ FCC '?STAC' ; '?STACK'
+ FCB $CB
+ FDB DOTQ-5
+QSTACK FDB DOCOL,LIT8
+* FCB $12
+ FCB SINIT-ORIG
+* But why use that instead of XSPZER (S0)?
+* Multi-user or multi-tasking would not want that.
+* CMPU <XSPZER
+* FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
+ FDB PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
+ FDB QERR
+* prints 'empty stack'
+*
+QSTAC2 FDB SPAT
+* Here, we compare with a value at least 128
+* higher than dict. ptr. (DICTPT)
+* FDB HERE,LIT8
+* FCB $80 ; This is a rough check anyway, leave it as is.
+* But shouldn't it be the terminal width?
+ FDB HERE,COLUMS,AT
+ FDB PLUS,LESS,ZBRAN
+ FDB QSTAC3-*-NATWID
+ FDB TWO ; NOT the NATWID constant!
+ FDB QERR
+* prints 'full stack'
+*
+QSTAC3 FDB SEMIS
+*
+* ======>> 127 << this word's function
+* is done by ?STACK in this version
+* FCB $85
+* FCC 4,?FREE
+* FCB $C5
+* FDB QSTACK-9
+*QFREE FDB DOCOL,SPAT,HERE,LIT8
+* FCB $80
+* FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
+*
+* ######>> screen 46 <<
+* ======>> 128 <<
+* ( buffer n --- )
+* ***** Check that this is how it works here:
+* Get up to n-1 characters from the keyboard,
+* storing at buffer and echoing, with backspace editing,
+* quitting when a CR is read.
+* Terminate it with a NUL.
+ FCB $86
+ FCC 'EXPEC' ; 'EXPECT'
+ FCB $D4
+ FDB QSTACK-9
+EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
+* EXPEC2 FDB KEY,DUP,LIT8
+EXPEC2 FDB KEY
+* FDB LIT,$1C,SHOTOS ; DBG
+ FDB DUP,LIT8
+ FCB BACKSP-ORIG
+ FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing
+ FDB EXPEC3-*-NATWID
+ FDB DROP,LIT8
+ FCB 8 ( backspace character to emit )
+ FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
+ FDB TOR,SUB,BRAN
+ FDB EXPEC6-*-NATWID
+EXPEC3 FDB DUP,LIT8
+ FCB $D ( carriage return )
+ FDB EQUAL,ZBRAN
+ FDB EXPEC4-*-NATWID
+ FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
+ FDB EXPEC5-*-NATWID
+EXPEC4 FDB DUP
+EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
+EXPEC6 FDB EMIT,XLOOP
+ FDB EXPEC2-*-NATWID
+ FDB DROP
+ FDB SEMIS
+*
+* ======>> 129 <<
+* ( --- )
+* EXPECT 128 (TWID) characters to TIB.
+ FCB $85
+ FCC 'QUER' ; 'QUERY'
+ FCB $D9
+ FDB EXPECT-9
+QUERY FDB DOCOL,TIB,AT,COLUMS
+ FDB AT,EXPECT,ZERO,IN,STORE
+ FDB SEMIS
+*
+* ======>> 130 <<
+* ( --- ) P
+* End interpretation of a line or screen, and/or prepare for a new block.
+* Note that the name of this definition is an empty string,
+* so it matches on the terminating NUL in the terminal or block buffer.
+ FCB $C1 immediate < carriage return >
+ FCB $80
+ FDB QUERY-8
+NULL FDB DOCOL,BLK,AT,ZBRAN
+ FDB NULL2-*-NATWID
+ FDB ONE,BLK,PSTORE
+ FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
+ FDB ZEQU
+* check for end of screen
+ FDB ZBRAN
+ FDB NULL1-*-NATWID
+ FDB QEXEC,FROMR,DROP
+NULL1 FDB BRAN
+ FDB NULL3-*-NATWID
+NULL2 FDB FROMR,DROP
+NULL3 FDB SEMIS
+*
+* ######>> screen 47 <<
+* ======>> 133 <<
+* ( adr n b --- )
+* Fill n bytes at adr with b.
+* This relies on CMOVE having a certain lack of parameter checking,
+* where overlapping regions are not properly inverted in copy.
+* And this really should be done in low-level.
+* None of the advantages of doing things in high-level apply to fill.
+ FCB $84
+ FCC 'FIL' ; 'FILL'
+ FCB $CC
+ FDB NULL-4
+FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
+ FDB FROMR,ONE,SUB,CMOVE
+ FDB SEMIS
+*
+* ======>> 134 <<
+* ( adr n --- )
+* Fill n bytes with 0.
+ FCB $85
+ FCC 'ERAS' ; 'ERASE'
+ FCB $C5
+ FDB FILL-7
+ERASE FDB DOCOL,ZERO,FILL
+ FDB SEMIS
+*
+* ======>> 135 <<
+* ( adr n --- )
+* Fill n bytes with ASCII SPACE.
+ FCB $86
+ FCC 'BLANK' ; 'BLANKS'
+ FCB $D3
+ FDB ERASE-8
+BLANKS FDB DOCOL,BL,FILL
+ FDB SEMIS
+*
+* ======>> 136 <<
+* ( c --- )
+* Format a character at the left of the HLD output buffer.
+ FCB $84
+ FCC 'HOL' ; 'HOLD'
+ FCB $C4
+ FDB BLANKS-9
+HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
+ FDB SEMIS
+*
+* ======>> 137 <<
+* ( --- adr )
+* Give the address of the output PAD buffer.
+* PAD points to the end of a 68 byte buffer for numeric conversion.
+ FCB $83
+ FCC 'PA' ; 'PAD'
+ FCB $C4
+ FDB HOLD-7
+PAD FDB DOCOL,HERE,LIT8
+ FCB $44
+ FDB PLUS
+ FDB SEMIS
+*
+* ######>> screen 48 <<
+* ======>> 138 <<
+* ( c --- )
+* Scan a string terminated by the character c or ASCII NUL out of input;
+* store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
+* Leading c are passed over, per ENCLOSE.
+* Scans from BLK, or from TIB if BLK is zero.
+* May overwrite the numeric conversion pad,
+* if really long (length > 31) symbols are scanned.
+ FCB $84
+ FCC 'WOR' ; 'WORD'
+ FCB $C4
+ FDB PAD-6
+WORD FDB DOCOL,BLK,AT,ZBRAN
+ FDB WORD2-*-NATWID
+ FDB BLK,AT,BLOCK,BRAN
+ FDB WORD3-*-NATWID
+WORD2 FDB TIB,AT
+WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
+ FCB 34
+ FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
+ FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
+ FDB SEMIS
+*
+* ######>> screen 49 <<
+* ======>> 139 <<
+* ( d1 string --- d2 adr )
+* Convert the text at string into a number, accumulating the result into d1,
+* leaving adr pointing to the first character not converted.
+* If DPL is non-negative at entry,
+* accumulates the number of characters converted into DPL.
+ FCB $88
+ FCC '(NUMBER' ; '(NUMBER)'
+ FCB $A9
+ FDB WORD-7
+PNUMB FDB DOCOL
+PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
+ FDB PNUMB4-*-NATWID
+ FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
+ FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
+ FDB PNUMB3-*-NATWID
+ FDB ONE,DPL,PSTORE
+PNUMB3 FDB FROMR,BRAN
+ FDB PNUMB2-*-NATWID
+PNUMB4 FDB FROMR
+ FDB SEMIS
+*
+* ======>> 140 <<
+* ( ctstr --- d )
+* Convert text at ctstr to a double integer,
+* taking the 0 ERROR if the conversion is not valid.
+* If a decimal point is present,
+* accumulate the count of digits to the decimal point's right into DPL
+* (negative DPL at exit indicates single precision).
+* ctstr is a counted string
+* -- the first byte at ctstr is the length of the string,
+* but NUMBER ignores the count and expects a NUL terminator instead.
+ FCB $86
+ FCC 'NUMBE' ; 'NUMBER'
+ FCB $D2
+ FDB PNUMB-11
+NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
+ FCC "-" minus sign
+ FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
+NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
+ FDB ZBRAN
+ FDB NUMB2-*-NATWID
+ FDB DUP,CAT,LIT8
+ FCC "."
+ FDB SUB,ZERO,QERR,ZERO,BRAN
+ FDB NUMB1-*-NATWID
+NUMB2 FDB DROP,FROMR,ZBRAN
+ FDB NUMB3-*-NATWID
+ FDB DMINUS
+NUMB3 FDB SEMIS
+*
+* ======>> 141 <<
+* ( --- locptr length true ) { -FIND name } typical input
+* ( --- false )
+* Parse a word, then FIND,
+* first in the definition vocabulary,
+* then in the CONTEXT (interpretation) vocabulary, if necessary.
+* Returns what (FIND) returns, flag and optional location and length.
+ FCB $85
+ FCC '-FIN' ; '-FIND'
+ FCB $C4
+ FDB NUMB-9
+DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
+ FDB PFIND,DUP,ZEQU,ZBRAN
+ FDB DFIND2-*-NATWID
+ FDB DROP,HERE,LATEST,PFIND
+DFIND2 FDB SEMIS
+*
+* ######>> screen 50 <<
+* ======>> 142 <<
+* ( anything --- nothing ) ( anything *** nothing )
+* An indirection for ABORT, for ERROR,
+* which may be modified carefully.
+ FCB $87
+ FCC '(ABORT' ; '(ABORT)'
+ FCB $A9
+ FDB DFIND-8
+PABORT FDB DOCOL,ABORT
+ FDB SEMIS
+*
+* ======>> 143 <<
+ FCB $85
+ FCC 'ERRO' ; 'ERROR'
+ FCB $D2
+ FDB PABORT-10
+* This really should not be high level, according to best practices.
+* But fixing that cascades through MESSAGE,
+* requiring re-architecting the disk block system.
+* First, we need to get this transliteration running.
+ERROR FDB DOCOL,WARN,AT,ZLESS
+ FDB ZBRAN
+ FDB ERROR2-*-NATWID
+* note: WARNING is
+* -1 to abort,
+* 0 to print error #
+* and 1 to print error message from disc
+ FDB PABORT
+ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
+ FCB 4,7 ( bell )
+ FCC " ? "
+ FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
+ FDB SEMIS
+*
+* ======>> 144 <<
+* ( n adr --- )
+* Mask byte at adr with n.
+* Not in FIG, don't need it for 8 bit characters after all.
+* FCB $85
+* FCC 'CMAS' ; 'CMASK'
+* FCB $CB ; 'K'
+* FDB ERROR-8
+* CMASK FDB *+NATWID
+* LDX ,U++ ; adr
+* LDD ,U++ ; mask
+* ANDB ,X
+* STB ,X
+* LBRA NEXT
+*
+* ( 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
+ LBRA NEXT
+*
+* ( symptr --- )
+* Print definition's name from its NFA.
+ FCB $83
+ FCC 'ID' ; 'ID.'
+ FCB $AE
+ FDB IDFLAT-9
+IDDOT FDB DOCOL,PAD,LIT8
+ FCB 32
+ FDB LIT8
+ FCB $5F ( underline )
+ FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
+* FDB SWAP,CMOVE,PAD,COUNT,LIT8
+ FDB SWAP,CMOVE,PAD
+ FDB IDFLAT
+ FDB COUNT,LIT8
+ FCB 31
+ FDB AND,TYPE,SPACE
+ FDB SEMIS
+*
+* ######>> screen 51 <<
+* ======>> 145 <<
+* ( --- ) { CREATE name } input
+* Parse a name (length < 32 characters) and create a header,
+* reporting first duplicate found in either the defining vocabulary
+* or the context (interpreting) vocabulary.
+* Install the header in the defining vocabulary
+* with CFA dangerously pointing to the parameter field.
+* Leave the name SMUDGEd.
+ FCB $86
+ FCC 'CREAT' ; 'CREATE'
+ FCB $C5
+ FDB IDDOT-6
+CREATE FDB DOCOL,DFIND,ZBRAN
+ FDB CREAT2-*-NATWID
+ FDB DROP,PDOTQ
+ FCB 8
+ FCB 7 ( bel )
+ FCC "redef: "
+ FDB NFA,IDDOT,LIT8
+ FCB 4
+ FDB MESS,SPACE
+CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
+ FDB ONEP,ALLOT,DUP,LIT8
+ FCB ($80|FSMUDG) ; Bracket the name.
+ FDB TOGGLE,HERE,ONE,SUB,LIT8
+ FCB $80
+ FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
+* FDB HERE,TWOP,COMMA
+ FDB HERE,NATP,COMMA
+ FDB SEMIS
+*
+* ######>> screen 52 <<
+* ======>> 146 <<
+* ( --- ) P
+* { [COMPILE] name } typical use
+* -DFIND next WORD and COMPILE it, literally;
+* used to compile immediate definitions into words.
+ FCB $C9 immediate
+ FCC '[COMPILE' ; '[COMPILE]'
+ FCB $DD
+ FDB CREATE-9
+BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
+ FDB SEMIS
+*
+* ======>> 147 <<
+* ( n --- ) if compiling. P
+* ( n --- n ) if interpreting.
+* Compile n as a literal, if compiling.
+ FCB $C7 immediate
+ FCC 'LITERA' ; 'LITERAL'
+ FCB $CC
+ FDB BCOMP-12
+LITER FDB DOCOL,STATE,AT,ZBRAN
+ FDB LITER2-*-NATWID
+ FDB COMPIL,LIT,COMMA
+LITER2 FDB SEMIS
+*
+* ======>> 148 <<
+* ( d --- ) if compiling. P
+* ( d --- d ) if interpreting.
+* Compile d as a double literal, if compiling.
+ FCB $C8 immediate
+ FCC 'DLITERA' ; 'DLITERAL'
+ FCB $CC
+ FDB LITER-10
+DLITER FDB DOCOL,STATE,AT,ZBRAN
+ FDB DLITE2-*-NATWID
+ FDB SWAP,LITER,LITER ; Just two literals in the right order.
+DLITE2 FDB SEMIS
+*
+* ######>> screen 53 <<
+* ======>> 149 <<
+* ( --- )
+* Interpret or compile, according to STATE.
+* Searches words parsed in dictionary first, via -FIND,
+* then checks for valid NUMBER.
+* Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
+* ERROR checks the stack via ?STACK before returning to its caller.
+ FCB $89
+ FCC 'INTERPRE' ; 'INTERPRET'
+ FCB $D4
+ FDB DLITER-11
+INTERP FDB DOCOL
+INTER2 FDB DFIND,ZBRAN
+ FDB INTER5-*-NATWID
+ FDB STATE,AT,LESS
+ FDB ZBRAN
+ FDB INTER3-*-NATWID
+ FDB CFA,COMMA,BRAN
+ FDB INTER4-*-NATWID
+INTER3 FDB CFA,EXEC
+INTER4 FDB BRAN
+ FDB INTER7-*-NATWID
+INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
+ FDB INTER6-*-NATWID
+ FDB DLITER,BRAN
+ FDB INTER7-*-NATWID
+INTER6 FDB DROP,LITER
+INTER7 FDB QSTACK,BRAN
+ FDB INTER2-*-NATWID
+* FDB SEMIS never executed
+
+*
+* ######>> screen 54 <<
+* ======>> 150 <<
+* ( --- )
+* Toggle precedence bit of LATEST definition header.
+* During compiling, most symbols scanned are compiled.
+* IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
+* but may be compiled via ' (TICK).
+ FCB $89
+ FCC 'IMMEDIAT' ; 'IMMEDIATE'
+ FCB $C5
+ FDB INTERP-12
+IMMED FDB DOCOL,LATEST,LIT8
+ FCB FIMMED
+ FDB TOGGLE
+ FDB SEMIS
+*
+* ======>> 151 <<
+* ( --- ) { VOCABULARY name } input
+* Create a vocabulary entry with a flag for terminating vocabulary searches.
+* Store the current search context in it for linking.
+* At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
+ FCB $8A
+ FCC 'VOCABULAR' ; 'VOCABULARY'
+ FCB $D9
+ FDB IMMED-12
+VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
+ FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
+* DOVOC FDB TWOP,CONTXT,STORE
+DOVOC FDB NATP,CONTXT,STORE
+ FDB SEMIS
+*
+* ======>> 152 <<
+*
+* Note: FORTH does not go here in the rom-able dictionary,
+* since FORTH is a type of variable.
+*
+* (Should make a proper architecture for this at some point.)
+*
+*
+* ======>> 153 <<
+* ( --- )
+* Makes the current interpretation CONTEXT vocabulary
+* also the CURRENT defining vocabulary.
+ FCB $8B
+ FCC 'DEFINITION' ; 'DEFINITIONS'
+ FCB $D3
+ FDB VOCAB-13
+DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
+ FDB SEMIS
+*
+* ======>> 154 <<
+* ( --- )
+* Parse out a comment and toss it away.
+* Leaves the leading characters in WORDPAD, which may or may not be useful.
+ FCB $C1 immediate (
+ FCB $A8
+ FDB DEFIN-14
+PAREN FDB DOCOL,LIT8
+ FCC ")"
+ FDB WORD
+ FDB SEMIS
+*
+* ######>> screen 55 <<
+* ======>> 155 <<
+* ( anything *** nothing )
+* Clear return stack.
+* Then INTERPRET and, if not compiling, prompt with OK,
+* in infinite loop.
+ FCB $84
+ FCC 'QUI' ; 'QUIT'
+ FCB $D4
+ FDB PAREN-4
+QUIT FDB DOCOL,ZERO,BLK,STORE
+ FDB LBRAK
+*
+* Here is the outer interpretter
+* which gets a line of input, does it, prints " OK"
+* then repeats :
+QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
+ FDB ZBRAN
+ FDB QUIT3-*-NATWID
+ FDB PDOTQ
+ FCB 3
+ FCC ' OK' ; ' OK'
+QUIT3 FDB BRAN
+ FDB QUIT2-*-NATWID
+* FDB SEMIS ( never executed )
+*
+* ======>> 156 <<
+* ( anything --- nothing ) ( anything *** nothing )
+* Clear parameter stack,
+* set STATE to interpret and BASE to DECIMAL,
+* return to input from terminal,
+* restore DRIVE OFFSET to 0,
+* print out "Forth-68",
+* set interpret and define vocabularies to FORTH,
+* and finally, QUIT.
+* Used to force the system to a known state
+* and return control to the initial INTERPRETer.
+ FCB $85
+ FCC 'ABOR' ; 'ABORT'
+ FCB $D4
+ FDB QUIT-7
+ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
+ FCB 14
+ FCC "fig-Forth-6809"
+ FDB FORTH,DEFIN
+ FDB QUIT
+* FDB SEMIS never executed
+ PAGE
+*
+* ######>> screen 56 <<
+* bootstrap code... moves rom contents to ram :
+* ======>> 157 <<
+ FCB $84
+ FCC 'COL' ; 'COLD'
+ FCB $C4
+ FDB ABORT-8
+COLD FDB *+NATWID
+* Ultimately, we want position indepence,
+* so I'm using PCR where it seems reasonable.
+CENT LDS RINIT,PCR ; Get a useable return stack, at least.
+ LDU SINIT,PCR ; Get a useable parameter stack, too.
+ LDA #IUPDP ; This is not relative to PC.
+ TFR A,DP ; And a useable direct page, too.
+ SETDP IUPDP ; (For good measure.)
+*
+* CLR TRACEM ; DBG
+* DEC TRACEM ; DBG
+* LBSR DBGREG
+* 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
+* LBSR DBGREG
+ CMPX <XFENCE
+ BNE COLD2
+* Leaves USE and PREV uninitialized.
+ LDX BUFINT,PCR
+ STX <XUSE
+ STX <XPREV
+* LEAX RAM,PCR
+* STX <XFENCE ; Borrow this variable for a loop terminator.
+* LEAY REND,PCR ; top of destination (included XUSE and XPREV)
+* LEAX ERAM,PCR ; top of stuff to move (included initializers for XUSE and XPREV)
+* COLD2 LDA ,-X
+* STA ,-Y ; move TASK & FORTH to ram
+* CMPX <XFENCE
+* BNE COLD2
+*
+* CENT LDS #REND-1 top of destination
+* LDX #ERAM top of stuff to move
+* COLD2 LEAX -1,X ;
+* LDA 0,X
+* PSHS A ; move TASK & FORTH to ram
+* CMPX #RAM
+* BNE COLD2
+*
+* LDS #XFENCE-1 put stack at a safe place for now
+* But that is taken care of.
+* LDX COLINT
+* STX XCOLUM
+ LDX COLINT,PCR
+ STX <XCOLUM
+* LDX DELINT
+* STX XDELAY
+ LDX DELINT,PCR
+ STX <XDELAY
+* LDX VOCINT
+* STX XVOCL
+ LDX VOCINT,PCR
+ STX <XVOCL
+* LDX DPINIT
+* STX XDICTP
+ LDX DPINIT,PCR
+ STX <XDICTP
+* LDX FENCIN
+* STX XFENCE
+ LDX FENCIN,PCR
+ STX <XFENCE
+*
+WENT LDS SINIT,PCR ; Get a useable return stack, at least.
+ LDA #IUPDP ; This is not relative to PC.
+ TFR A,DP ; And a useable direct page, too.
+ SETDP IUPDP ; (For good measure.)
+*
+ LEAX SINIT,PCR
+ PSHS X ; for loop termination
+ CLRB ; Yes, I'm being a little ridiculous. Only a little.
+ TFR D,Y
+ LEAY XFENCE-UORIG,Y ; top of destination
+ LEAX FENCIN,PCR ; top of stuff to move
+WARM2 LDD ,--X ; All entries are 16 bit.
+ STD ,--Y
+* LBSR DBGREG
+ CMPX ,S
+ BNE WARM2
+ LEAS 2,S ; But we'll reset the return stack shortly, anyway.
+ LDU <XSPZER ; So we can clear the hole above the TOS
+* WENT LDS #XFENCE-1 top of destination
+* LDX #FENCIN top of stuff to move
+* WARM2 LEAX -1,X ;
+* LDA 0,X
+* PSHS A ;
+* CMPX #SINIT
+* BNE WARM2
+*
+* LDS SINIT
+* S is already there.
+* LDX UPINIT
+* STX UP init user ram pointer
+* UP is already there (DP).
+* LDX #ABORT
+* STX IP
+ LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
+*
+ NOP Here is a place to jump to special user
+ NOP initializations such as I/0 interrups
+ NOP
+*
+* For systems with TRACE:
+ LDX #00
+ STX ,U The hole above the parameter stack
+* STX TRLIM clear trace mode
+ STX <TRLIM clear trace mode (both bytes)
+ LDX #0
+* STX BRKPT clear breakpoint address
+ STX <BRKPT ; clear breakpoint address
+* JMP RPSTOR+2 start the virtual machine running !
+ JMP [RPSTOR,PCR] ; start the virtual machine running !
+* RPSTOR's NEXT will pick up the IP in Y, set above, and start ABORT.
+* LBSR RPSTOR+NATWID ; start the virtual machine running !
+* LEAX WENT,PCR ; But we must also give RP! someplace to return.
+* STX ,S ; This rail might get walked on by (DO).
+* LBRA NEXT
+* RP! sets up the return stack pointer, then Y references abort.
+*
+* Here is the stuff that gets copied to ram :
+* (not * at address $140:)
+* at an appropriate address:
+*
+* RAM FDB $3000,$3000,0,0
+* RAM FDB BUFBAS,BUFBAS,0,0 ; ... except the direct page has moved.
+* These initialization values for USE and PREV were here to help pack the code.
+* They don't belong here unless we move the USER table
+* back below the writable dictionary,
+* *and* move these USER variables to the end of the direct page --
+* *or* let these definitions exist in the USER table.
+RAM EQU *
+
+* ======>> (152) <<
+* ( --- ) P
+* Makes FORTH the current interpretation vocabulary.
+* In order to make this ROMmable, this entry is set up as the tail-end,
+* and copied to RAM in the start-up code.
+* We want a more elegant solution to this, too. Greedy, maybe.
+ FCB $C5 immediate
+ FCC 'FORT' ; 'FORTH'
+ FCB $C8
+ FDB NOOP-7 ; Note that this does not link to COLD!
+RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
+ FDB 0
+ FCC "Copyright 1979 Forth Interest Group, David Lion,"
+ FCB $0D
+ FCC "Parts Copyright 2019 Joel Matthew Rees"
+ FCB $0D
+ FCB $84
+ FCC 'TAS' ; 'TASK'
+ FCB $CB
+ FDB FORTH-8
+RTASK FDB DOCOL,SEMIS
+ERAM EQU *
+ERAMSZ EQU *-RAM ; So we can get a look at it.
+ PAGE
+*
+* ######>> screen 57 <<
+* ======>> 158 <<
+* ( n0 --- d0 )
+* Sign extend n0 to a double integer.
+ FCB $84
+ FCC 'S->' ; 'S->D'
+ FCB $C4
+ FDB COLD-7 ; Note that this does not link to FORTH (RFORTH)!
+STOD FDB DOCOL,DUP,ZLESS,MINUS
+ FDB SEMIS
+
+
+*
+* ======>> 159 <<
+* ( multiplier multiplicand --- product )
+* Signed word multiply.
+ FCB $81 ; *
+ FCB $AA
+ FDB STOD-7
+STAR FDB DOCOL
+ FDB USTAR,DROP,SEMIS ; Drop high word.
+* STAR FDB *+NATWID
+* LBSR USTAR+NATWID ; or [USTAR,PCR]?
+* LEAU NATWID,U ; Drop high word. Seems like magic, doesn't it?
+* LBRA NEXT
+* JSR USTARS
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP NEXT
+*
+* ======>> 160 <<
+* ( dividend divisor --- remainder quotient )
+* M/ in word-only form, i. e., signed division of 2nd word by top word,
+* yielding signed word quotient and remainder.
+* Except *BUG* it isn't signed.
+ FCB $84
+ FCC '/MO' ; '/MOD'
+ FCB $C4
+ FDB STAR-4
+SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
+ FDB SEMIS
+*
+* ======>> 161 <<
+* ( dividend divisor --- quotient )
+* Signed word divide without remainder.
+* Except *BUG* it isn't signed.
+ FCB $81 ; /
+ FCB $AF
+ FDB SLMOD-7
+SLASH FDB DOCOL,SLMOD,SWAP,DROP
+ FDB SEMIS
+*
+* ======>> 162 <<
+* ( dividend divisor --- remainder )
+* Remainder function, result takes sign of dividend.
+ FCB $83
+ FCC 'MO' ; 'MOD'
+ FCB $C4
+ FDB SLASH-4
+MOD FDB DOCOL,SLMOD,DROP
+ FDB SEMIS
+*
+* ======>> 163 <<
+* ( multiplier multiplicand divisor --- remainder quotient )
+* Signed precise division of product:
+* multiply 2nd and 3rd words on stack
+* and divide the 31-bit product by the top word,
+* leaving both quotient and remainder.
+* Remainder takes sign of product.
+* Guaranteed not to lose significant bits in 16 bit integer math.
+ FCB $85
+ FCC '*/MO' ; '*/MOD'
+ FCB $C4
+ FDB MOD-6
+SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
+ FDB SEMIS
+*
+* ======>> 164 <<
+* ( multiplier multiplicand divisor --- quotient )
+* */MOD without remainder.
+ FCB $82
+ FCC '*' ; '*/'
+ FCB $AF
+ FDB SSMOD-8
+SSLASH FDB DOCOL,SSMOD,SWAP,DROP
+ FDB SEMIS
+*
+* ======>> 165 <<
+* ( ud1 u1 --- u2 ud2 )
+* U/ with an (unsigned) double quotient.
+* Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
+* if you are prepared to deal with the extra 16 bits of result.
+ FCB $85
+ FCC 'M/MO' ; 'M/MOD'
+ FCB $C4
+ FDB SSLASH-5
+MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
+ FDB FROMR,SWAP,TOR,USLASH,FROMR
+ FDB SEMIS
+*
+* ======>> 166 <<
+* ( n>=0 --- n )
+* ( n<0 --- -n )
+* Convert the top of stack to its absolute value.
+ FCB $83
+ FCC 'AB' ; 'ABS'
+ FCB $D3
+ FDB MSMOD-8
+ABS FDB DOCOL,DUP,ZLESS,ZBRAN
+ FDB ABS2-*-NATWID
+ FDB MINUS
+ABS2 FDB SEMIS
+*
+* ======>> 167 <<
+* ( d>=0 --- d )
+* ( d<0 --- -d )
+* Convert the top double to its absolute value.
+ FCB $84
+ FCC 'DAB' ; 'DABS'
+ FCB $D3
+ FDB ABS-6
+DABS FDB DOCOL,DUP,ZLESS,ZBRAN
+ FDB DABS2-*-NATWID
+ FDB DMINUS
+DABS2 FDB SEMIS
+*
+* ######>> screen 58 <<
+* Disc primitives :
+* ======>> 168 <<
+* ( --- vadr )
+* Least Recently Used buffer.
+* Really should be with FIRST and LIMIT in the per-task table.
+ FCB $83
+ FCC 'US' ; 'USE'
+ FCB $C5
+ FDB DABS-7
+USE FDB DOCON
+ FDB XUSE
+* ======>> 169 <<
+* ( --- vadr )
+* Most Recently Used buffer.
+* Really should be with FIRST and LIMIT in the per-task table.
+ FCB $84
+ FCC 'PRE' ; 'PREV'
+ FCB $D6
+ FDB USE-6
+PREV FDB DOCON
+ FDB XPREV
+* ======>> 170 <<
+* ( buffer1 --- buffer2 f )
+* Bump to next buffer,
+* flag false if result is PREVious buffer,
+* otherwise flag true.
+* Used in the LRU allocation routines.
+ FCB $84
+ FCC '+BU' ; '+BUF'
+ FCB $C6
+ FDB PREV-7
+* PBUF FDB DOCOL,LIT8
+* FCB $84 ; This was a hard-wiring bug.
+PBUF FDB DOCOL,BBUF,BCTL,PLUS ; Size of the buffer record.
+* FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
+ FDB PLUS,DUP,LIMIT,LESS,ZEQU,OVER,FIRST,LESS,OR,ZBRAN
+ FDB PBUF2-*-NATWID ; Use defensive programming.
+ FDB DROP,FIRST
+PBUF2 FDB DUP,PREV,AT,SUB
+ FDB SEMIS
+*
+* ======>> 171 <<
+* ( --- f )
+* Flag to mark a buffer dirty, in need of being written out.
+* This flag limits the max number of sectors in a disk to ((256^NATWID)/2)-1.
+* It also hard-codes an implicit test which is used elsewhere.
+ FCB $8A
+ FCC 'UPDATE-BI' ; 'UPDATE-BIT'
+ FCB $D4
+ FDB PBUF-7
+UPDBIT FDB DOCON
+ FDB $8000
+*
+* ( --- )
+* Mark PREVious buffer dirty, in need of being written out.
+ FCB $86
+ FCC 'UPDAT' ; 'UPDATE'
+ FCB $C5
+ FDB UPDBIT-13
+* UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
+UPDATE FDB DOCOL,PREV,AT,AT,UPDBIT,OR,PREV,AT,STORE
+ FDB SEMIS
+*
+* ======>> 172 <<
+* ( adr --- )
+* Mark the buffer addressed as empty.
+* Have to add code to avoid block 0 appearing to be in a buffer from COLD.
+* Usually, there is no sector 0 (?), but the RAM buffers are too simple.
+* Note that without this block number being made illegal,
+* about 8 binaryMegabytes (256 bytes/block) of disk can be addressed total.
+* With this block number made illegal, the max is 1 block less,
+* still about 8 biMeg.
+ FCB $8B
+ FCC 'KILL-BUFFE' ; 'KILL-BUFFER'
+ FCB $D2
+ FDB UPDATE-9
+KILBUF FDB *+NATWID ; DOCOL,UPDBIT,ONE,SUB,SWAP,STORE
+ PULU X
+ LDD UPDBIT+NATWID,PCR
+ SUBD #1
+ STD ,X
+* LBSR DBGREG
+ LBRA NEXT
+*
+* ( --- )
+* Mark all buffers empty.
+ FCB $8C
+ FCC 'KILL-BUFFER' ; 'KILL-BUFFERS'
+ FCB $D3
+ FDB KILBUF-14
+KLBFS FDB DOCOL,FIRST,LIT8
+ FCB 4 ; Want to make sure it's only four.
+ FDB ZERO,XDO ; It would be "cleaner" to let +BUF control the loop.
+ FDB DUP,KILBUF,PBUF,DROP,XLOOP
+ FDB DROP,SEMIS
+* 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
+* LBRA NEXT
+*
+* ( --- )
+* Erase and mark all buffers empty.
+* Standard method of discarding changes.
+ FCB $8D
+ FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
+ FCB $D3
+ FDB KLBFS-15
+MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
+* FDB FIRST,DUP,KILBUF,PBUF,DROP,DUP,KILBUF
+* FDB PBUF,DROP,DUP,KILBUF,PBUF,DROP,KILBUF
+ FDB KLBFS
+ FDB SEMIS
+*
+* ======>> 173 <<
+* ( --- )
+* Clear the current offset to the block numbers in the drive interface.
+* The drives need to be re-architected.
+* Would be cool to have RAM and ROM drives supported
+* in addition to regular physical persistent store.
+ FCB $83
+ FCC 'DR' ; 'DR0'
+ FCB $B0
+ FDB MTBUF-16
+DRZERO FDB DOCOL,ZERO,OFSET,STORE
+ FDB SEMIS
+*
+* ======>> 174 <<== system dependant word
+* ( --- )
+* Set the current offset in the drive interface to reference the second drive.
+* The hard-coded number in there needs to be in a table.
+ FCB $83
+ FCC 'DR' ; 'DR1'
+ FCB $B1
+ FDB DRZERO-6
+DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
+; **** hard-codes the size of the disc !!!!
+ FDB SEMIS
+*
+* ######>> screen 59 <<
+* ======>> 175 <<
+* ( n --- buffer )
+* Get a free buffer,
+* assign it to block n,
+* return buffer address.
+* Will free a buffer by writing it, if necessary.
+* Does not actually read the block.
+* A bug in the fig LRU algorithm, which I have not fixed,
+* gives the PREVious buffer if USE gets set to PREVious.
+* (The bug is that USE sometimes gets set to PREVious.)
+* This bug sometimes causes sector moves to become sector fills.
+ FCB $86
+ FCC 'BUFFE' ; 'BUFFER'
+ FCB $D2
+ FDB DRONE-6
+BUFFER FDB DOCOL,USE,AT,DUP,TOR
+BUFFR2 FDB PBUF,ZBRAN
+ FDB BUFFR2-*-NATWID
+ FDB USE,STORE,R,AT,ZLESS
+ FDB ZBRAN
+ FDB BUFFR3-*-NATWID
+* FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
+ FDB R,NATP,R,AT,UPDBIT,LNOT,AND,ZERO,RW
+* BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
+BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
+ FDB SEMIS
+*
+* ######>> screen 60 <<
+* ======>> 176 <<
+* ( n --- buffer )
+* Get BUFFER containing block n, relative to OFFSET.
+* If block n is not in a buffer, bring it in.
+* Returns buffer address.
+ FCB $85
+ FCC 'BLOC' ; 'BLOCK'
+ FCB $CB
+ FDB BUFFER-9
+BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
+ FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
+ FDB BLOCK5-*-NATWID
+BLOCK3 FDB PBUF,ZEQU,ZBRAN
+ FDB BLOCK4-*-NATWID
+* FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
+ FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
+BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
+ FDB BLOCK3-*-NATWID
+ FDB DUP,PREV,STORE
+* BLOCK5 FDB FROMR,DROP,TWOP
+BLOCK5 FDB FROMR,DROP,NATP
+ FDB SEMIS
+*
+* ######>> screen 61 <<
+* ======>> 177 <<
+* ( line screen --- buffer C/L)
+* Bring in the sector containing the specified line of the specified screen.
+* Returns the buffer address and the width of the screen.
+* Screen number is relative to OFFSET.
+* The line number may be beyond screen 4,
+* (LINE) will get the appropriate screen.
+ FCB $86
+ FCC '(LINE' ; '(LINE)'
+ FCB $A9
+ FDB BLOCK-8
+PLINE FDB DOCOL,TOR,LIT8
+ FCB $40
+ FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
+ FCB $40
+ FDB SEMIS
+*
+* ======>> 178 <<
+* ( line screen --- )
+* Print the line of the screen as found by (LINE), suppress trailing BLANKS.
+ FCB $85
+ FCC '.LIN' ; '.LINE'
+ FCB $C5
+ FDB PLINE-9
+DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
+ FDB SEMIS
+*
+* ======>> 179 <<
+* ( n --- )
+* If WARNING is 0, print "MESSAGE #n";
+* otherwise, print line n relative to screen 4,
+* the line number may be negative.
+* Uses .LINE, but counter-adjusts to be relative to the real drive 0.
+ FCB $87
+ FCC 'MESSAG' ; 'MESSAGE'
+ FCB $C5
+ FDB DLINE-8
+MESS FDB DOCOL,WARN,AT,ZBRAN
+ FDB MESS3-*-NATWID
+ FDB DDUP,ZBRAN
+ FDB MESS3-*-NATWID
+ FDB LIT8
+ FCB 4
+ FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
+ FDB MESS4-*-NATWID
+MESS3 FDB PDOTQ
+ FCB 6
+ FCC 'err # ' ; 'err # '
+ FDB DOT
+MESS4 FDB SEMIS
+*
+* ======>> 180 <<
+* ( n --- )
+* Begin interpretation of screen (block) n.
+* See also ARROW, SEMIS, and NULL.
+ FCB $84
+ FCC 'LOA' ; 'LOAD' : input:scr #
+ FCB $C4
+ FDB MESS-10
+LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
+ FDB BSCR,STAR,BLK,STORE
+ FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
+ FDB SEMIS
+*
+* ======>> 181 <<
+* ( --- ) P
+* Continue interpreting source code on the next screen.
+ FCB $C3
+ FCC '--' ; '-->'
+ FCB $BE
+ FDB LOAD-7
+ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
+ FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
+ FDB SEMIS
+ PAGE
+*
+*
+* ######>> screen 63 <<
+* The next 4 subroutines are machine dependent, and are
+* called by words 13 through 16 in the dictionary.
+*
+* ======>> 182 << code for EMIT
+* ( --- ) No parameter stack effect.
+* Interfaces directly with ROM. Expects output character in D (therefore, B).
+* Output using rom CHROUT: redirectable to a printer on Coco.
+* Outputs the character on stack (low byte of 1 bit word/cell).
+PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.)
+ TFR B,A ; Coco ROM wants it in A.
+ CLRB
+ TFR B,DP ; Give the ROM its direct page.
+ JSR [$A002] ; Output the character in A.
+ PULS Y,U,DP,PC
+* PEMIT STB N save B
+* STX N+1 save X
+* LDB ACIAC
+* BITB #2 check ready bit
+* BEQ PEMIT+4 if not ready for more data
+* STA ACIAD
+* LDX UP
+* STB IOSTAT-UORIG,X
+* LDB N recover B & X
+* LDX N+1
+* RTS only A register may change
+* PEMIT JMP $E1D1 for MIKBUG
+* PEMIT FCB $3F,$11,$39 for PROTO
+* PEMIT JMP $D286 for Smoke Signal DOS
+*
+* ======>> 183 << code for KEY
+* ( --- ) No parameter stack effect.
+* Returns character or break flag in D, since this interfaces with Coco ROM.
+* Wait for key from POLCAT on Coco.
+* Returns the character code for the key pressed.
+PKEY PSHS Y,U,DP ; Must save everything important for this one.
+ LDA #$CF ; a cursor of sorts
+ CLRB
+ TFR B,DP
+ SETDP 0
+ LDX <$88 ; location
+ LDB ,X ; save glyph
+ STA ,X
+PKEYLP JSR [$A000]
+* STA $41A ; DBG!
+ BEQ PKEYLP
+* STD $418 ; DBG!
+ STB ,X ; restore
+PKEYR CLRB ; for the break flag, shares code with PQTER
+ CMPA #3 ; break key
+ BNE PKEYGT
+ COMB ; for the break flag
+PKEYGT EXG A,B ; Leave it in D for return.
+ PULS Y,U,DP,PC ; Shares exit with PQTER
+ SETDP IUPDP
+* PKEY STB N
+* STX N+1
+* LDB ACIAC
+* ASRB ;
+* BCC PKEY+4 no incoming data yet
+* LDA ACIAD
+* ANDA #$7F strip parity bit
+* LDX UP
+* STB IOSTAT+1-UORIG,X
+* LDB N
+* LDX N+1
+* RTS
+* PKEY JMP $E1AC for MIKBUG
+* PKEY FCB $3F,$14,$39 for PROTO
+* PKEY JMP $D289 for Smoke Signal DOS
+*
+* ######>> screen 64 <<
+* ======>> 184 << code for ?TERMINAL
+* ( --- f ) Should change this to no stack effect.
+* check break key using POLCAT
+* Returns a flag to tell whether the break key was pressed or not.
+PQTER PSHS Y,U,DP
+ CLRB
+ TFR B,DP
+ JSR [$A000] ; Look but don't wait.
+ BRA PKEYR
+* PQTER LDA ACIAC Test for 'break' condition
+* ANDA #$11 mask framing error bit and
+* input buffer full
+* BEQ PQTER2
+* LDA ACIAD clear input buffer
+* LDA #01
+* PQTER2 RTS
+
+
+ PAGE
+*
+* ======>> 185 << code for CR
+* ( --- ) No stack effect.
+* Interfaces directly with ROM.
+* For Coco just output a CR.
+* Also subject to redirection in Coco BASIC ROM.
+PCR LDB #$0D
+ BRA PEMIT ; Just steal the code.
+* PCR LDA #$D carriage return
+* BSR PEMIT
+* LDA #$A line feed
+* BSR PEMIT
+* LDA #$7F rubout
+* LDX UP
+* LDB XDELAY+1-UORIG,X
+* PCR2 DECB ;
+* BMI PQTER2 return if minus
+* PSHS B ; save counter
+* BSR PEMIT print RUBOUTs to delay.....
+* PULS B ;
+* BRA PCR2 repeat
+
+
+ PAGE
+*
+* ######>> screen 66 <<
+* ======>> 187 <<
+* ( ??? )
+* Query the disk, I suppose.
+* Not sure what the model had in mind for this stub.
+ FCB $85
+ FCC '?DIS' ; '?DISC'
+ FCB $C3
+ FDB ARROW-6
+QDISC FDB *+NATWID
+ JMP NEXT
+*
+* ######>> screen 67 <<
+* ======>> 189 <<
+* ( ??? )
+* Write one block of data to disk.
+* Parameters unspecified in model. Stub in model.
+ FCB $8B
+ FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
+ FCB $C5
+ FDB QDISC-8
+BWRITE FDB *+NATWID
+ JMP NEXT
+*
+* ######>> screen 68 <<
+* ======>> 190 <<
+* ( ??? )
+* Read one block of data from disk.
+* Parameters unspecified in model. Stub in model.
+ FCB $8A
+ FCC 'BLOCK-REA' ; 'BLOCK-READ'
+ FCB $C4
+ FDB BWRITE-14
+BREAD FDB *+NATWID
+ JMP NEXT
+*
+*The next 3 words are written to create a substitute for disc
+* mass memory,located between MASSLO & MASSHI in ram --
+* ($3210 and $3fff in the 6800 model).
+* ======>> 190.1 <<
+ FCB $82
+ FCC 'L' ; 'LO'
+ FCB $CF
+ FDB BREAD-13
+LO FDB DOCON
+ FDB MEMEND a system dependent equate at front
+*
+* ======>> 190.2 <<
+ FCB $82
+ FCC 'H' ; 'HI'
+ FCB $C9
+ FDB LO-5
+HI FDB DOCON
+ FDB MEMTOP ( $3FFF or $7FFF in this version )
+*
+* ######>> screen 69 <<
+* ======>> 191 <<
+* ( buffer sector f --- )
+* Read or Write the specified (absolute -- ignores OFFSET) sector
+* from or to the specified buffer.
+* A zero flag specifies write,
+* non-zero specifies read.
+* Sector is an unsigned integer,
+* buffer is the buffer's address.
+* Will need to use the CoCo ROM disk routines.
+* For now, provides a virtual disk in RAM.
+ FCB $83
+ FCC 'R/' ; 'R/W'
+ FCB $D7
+ FDB HI-5
+RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
+ FDB RW2-*-NATWID
+ FDB PDOTQ
+ FCB 8
+ FCC ' Range ?' ; ' Range ?'
+ FDB QUIT
+RW2 FDB FROMR,ZBRAN
+ FDB RW3-*-NATWID
+ FDB SWAP
+RW3 FDB BBUF,CMOVE
+ FDB SEMIS
+*
+* From BIF-6809:
+* RW PSHS Y,U,DP
+* LDY $C006 control table
+* LDX #DROFFS+7 ; This is BIF's table of drive sizes.
+* LDD 2,U
+* RWD SUBD ,X++ sectors
+* BHS RWD
+* BVC RWR table end?
+* LDD #6
+* PSHU D
+* JMP ERROR
+* RWR ADDD ,--X back one
+* PSHS X
+* PSHU D
+* LDD #18 sectors/track
+* PSHU D
+* DOCOL
+* FDB SLAMOD
+* FDB XMACH
+* PULU D
+* STB 2,Y track
+* PULU D
+* INCB
+* STB 3,Y sector
+* PULS D table entry
+* SUBD #DROFFS+7
+* ASRB drive #
+* STB 1,Y
+* LDD 4,U buffer
+* STD 4,Y
+* LDB #2 coco READ
+* LDX ,U 0?
+* BNE *+3
+* INCB coco WRITE
+* STB ,Y op code
+* CLRA
+* TFR A,DP
+* JSR [$C004] ROM handles timeout
+* PULS Y,U,DP if IRQ enabled
+* LEAU 6,U
+* LDX $C006
+* LDB 6,X coco status
+* BEQ RWE
+* LDX <UP
+* LDD #0 no disc
+* STD UWARN,X
+* LDD #8
+* PSHU D
+* JMP ERROR
+* RWE NEXT
+*
+* ######>> screen 72 <<
+* ======>> 192 <<
+* ( --- ) compiling P
+* ( --- adr ) interpreting
+* { ' name } input
+* Parse a symbol name from input and search the dictionary for it, per -FIND;
+* compile the address as a literal if compiling,
+* otherwise just push it.
+ FCB $C1 immediate
+ FCB $A7 ' ( tick )
+ FDB RW-6
+TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
+ FDB SEMIS
+*
+* ======>> 193 <<
+* ( --- ) { FORGET name } input
+* Parse out name of definition to FORGET to, -DFIND it,
+* then lop it and everything that follows out of the dictionary.
+* In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
+ FCB $86
+ FCC 'FORGE' ; 'FORGET'
+ FCB $D4
+ FDB TICK-4
+FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
+ FCB $18
+ FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT8
+ FCB $15
+ FDB QERR,DUP,ZERO,PORIG,GREAT,LIT8
+ FCB $15
+ FDB QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
+ FDB SEMIS
+*
+* ######>> screen 73 <<
+* ======>> 194 <<
+* ( adr --- ) C
+* Calculate a back reference from HERE and compile it.
+ FCB $84
+ FCC 'BAC' ; 'BACK'
+ FCB $CB
+ FDB FORGET-9
+* BACK FDB DOCOL,HERE,SUB,COMMA
+BACK FDB DOCOL,HERE,NATP,SUB,COMMA
+ FDB SEMIS
+*
+* ======>> 195 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop test UNTIL
+* typical use: BEGIN code-loop AGAIN
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* ( --- adr n ) compile time P,C
+* Push HERE for BACK reference for general (non-counting) loops,
+* with BEGIN construct flag.
+* A better flag: $4245 (ASCII for 'BE').
+ FCB $C5
+ FCC 'BEGI' ; 'BEGIN'
+ FCB $CE
+ FDB BACK-7
+BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
+ FDB SEMIS
+*
+* ======>> 196 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ENDIF is just a sort of intersection piece,
+* marking where execution resumes after both branches.
+* ( adr n --- ) compile time
+* Check the mark and resolve the IF.
+* A better flag: $4846 (ASCII for 'IF').
+ FCB $C5
+ FCC 'ENDI' ; 'ENDIF'
+ FCB $C6
+ FDB BEGIN-8
+ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
+* FDB OVER,SUB,SWAP,STORE
+ FDB OVER,NATP,SUB,SWAP,STORE
+ FDB SEMIS
+*
+* ======>> 197 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ( adr n --- )
+* Alias for ENDIF .
+ FCB $C4
+ FCC 'THE' ; 'THEN'
+ FCB $CE
+ FDB ENDIF-8
+THEN FDB DOCOL,ENDIF
+ FDB SEMIS
+*
+* ======>> 198 <<
+* ( limit index --- ) runtime
+* typical use: DO code-loop LOOP
+* typical use: DO code-loop increment +LOOP
+* Counted loop, index is initial value of index.
+* Will loop until index equals (positive going)
+* or passes (negative going) limit.
+* ( --- adr n ) compile time P,C
+* Compile (DO), push HERE for BACK reference,
+* and push DO control construct flag.
+* A better flag: $444F (ASCII for 'DO').
+ FCB $C2
+ FCC 'D' ; 'DO'
+ FCB $CF
+ FDB THEN-7
+DO FDB DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
+ FDB SEMIS
+*
+* ======>> 199 <<
+* ( --- ) runtime
+* typical use: DO code-loop LOOP
+* Increments the index by one and branches back to beginning of loop.
+* Will loop until index equals limit.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (LOOP), fill in BACK reference.
+* A better flag: $444F (ASCII for 'DO').
+ FCB $C4
+ FCC 'LOO' ; 'LOOP'
+ FCB $D0
+ FDB DO-5
+LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
+ FDB SEMIS
+*
+* ======>> 200 <<
+* ( n --- ) runtime
+* typical use: DO code-loop increment +LOOP
+* Increments the index by n and branches back to beginning of loop.
+* Will loop until index equals (positive going)
+* or passes (negative going) limit.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (+LOOP), fill in BACK reference.
+* A better flag: $444F (ASCII for 'DO').
+ FCB $C5
+ FCC '+LOO' ; '+LOOP'
+ FCB $D0
+ FDB LOOP-7
+PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
+ FDB SEMIS
+*
+* ======>> 201 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test UNTIL
+* Will loop until UNTIL tests true.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (0BRANCH), fill in BACK reference.
+* A better flag: $4245 (ASCII for 'BE').
+ FCB $C5
+ FCC 'UNTI' ; 'UNTIL' : ( same as END )
+ FCB $CC
+ FDB PLOOP-8
+UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
+ FDB SEMIS
+*
+* ######>> screen 74 <<
+* ======>> 202 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test END
+* ( adr n --- )
+* Alias for UNTIL .
+ FCB $C3
+ FCC 'EN' ; 'END'
+ FCB $C4
+ FDB UNTIL-8
+END FDB DOCOL,UNTIL
+ FDB SEMIS
+*
+* ======>> 203 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop AGAIN
+* Will loop forever
+* (or until something uses R> DROP to force the current definition to die,
+* or perhaps ABORT or ERROR or some such other drastic means stops things).
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (0BRANCH), fill in BACK reference.
+* A better flag: $4245 (ASCII for 'BE').
+ FCB $C5
+ FCC 'AGAI' ; 'AGAIN'
+ FCB $CE
+ FDB END-6
+AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
+ FDB SEMIS
+*
+* ======>> 204 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* Will loop until WHILE tests false, skipping code-true on end.
+* REPEAT marks where execution resumes after the WHILE find a false flag.
+* ( aadr1 n1 adr2 n2 --- ) compile time P,C
+* Check the marks for WHILE and BEGIN,
+* compile BRANCH and BACK fill adr1 reference,
+* FILL-IN 0BRANCH reference at adr2.
+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+ FCB $C6
+ FCC 'REPEA' ; 'REPEAT'
+ FCB $D4
+ FDB AGAIN-8
+REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
+ FDB TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
+ FDB SEMIS
+*
+* ======>> 205 <<
+* ( n --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* Will pass execution to the true part on a true flag
+* and to the false part on a false flag.
+* ( --- adr n ) compile time P,C
+* Compile a 0BRANCH and dummy offset
+* and push IF reference to fill in and
+* IF control construct flag.
+* A better flag: $4946 (ASCII for 'IF').
+ FCB $C2
+ FCC 'I' ; 'IF'
+ FCB $C6
+ FDB REPEAT-9
+IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
+ FDB SEMIS
+*
+* ======>> 206 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ELSE is just a sort of intersection piece,
+* marking where execution resumes on a false branch.
+* ( adr1 n --- adr2 n ) compile time P,C
+* Check the marks,
+* compile BRANCH with dummy offset,
+* resolve IF reference,
+* and leave reference to BRANCH for ELSE.
+* A better flag: $4946 (ASCII for 'IF').
+ FCB $C4
+ FCC 'ELS' ; 'ELSE'
+ FCB $C5
+ FDB IF-5
+ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
+ FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
+ FDB SEMIS
+*
+* ======>> 207 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* Will loop until WHILE tests false, skipping code-true on end.
+* ( --- adr n ) compile time P,C
+* Compile 0BRANCH with dummy offset (using IF),
+* push WHILE reference.
+* BEGIN flag will sit underneath this.
+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+ FCB $C5
+ FCC 'WHIL' ; 'WHILE'
+ FCB $C5
+ FDB ELSE-7
+WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
+ FDB SEMIS
+*
+* ######>> screen 75 <<
+* ======>> 208 <<
+* ( count --- )
+* EMIT count spaces, for non-zero, non-negative counts.
+ FCB $86
+ FCC 'SPACE' ; 'SPACES'
+ FCB $D3
+ FDB WHILE-8
+SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
+ FDB SPACE3-*-NATWID
+ FDB ZERO,XDO
+SPACE2 FDB SPACE,XLOOP
+ FDB SPACE2-*-NATWID
+SPACE3 FDB SEMIS
+*
+* ======>> 209 <<
+* ( --- )
+* Initialize HLD for converting a double integer.
+* Stores the PAD address in HLD.
+ FCB $82
+ FCC '<' ; '<#'
+ FCB $A3
+ FDB SPACES-9
+BDIGS FDB DOCOL,PAD,HLD,STORE
+ FDB SEMIS
+*
+* ======>> 210 <<
+* ( d --- string length )
+* Terminate numeric conversion,
+* drop the number being converted,
+* leave the address of the conversion string and the length, ready for TYPE.
+ FCB $82
+ FCC '#' ; '#>'
+ FCB $BE
+ FDB BDIGS-5
+EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
+ FDB SEMIS
+*
+* ======>> 211 <<
+* ( n d --- d )
+* Put sign of n (as a flag) at the head of the conversion string.
+* Drop the sign flag.
+ FCB $84
+ FCC 'SIG' ; 'SIGN'
+ FCB $CE
+ FDB EDIGS-5
+SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
+ FDB SIGN2-*-NATWID
+ FDB LIT8
+ FCC "-"
+ FDB HOLD
+SIGN2 FDB SEMIS
+*
+* ======>> 212 <<
+* ( d --- d/base )
+* Generate next most significant digit in the conversion BASE,
+* putting the digit at the head of the conversion string.
+ FCB $81 #
+ FCB $A3
+ FDB SIGN-7
+DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
+ FCB 9
+ FDB OVER,LESS,ZBRAN
+ FDB DIG2-*-NATWID
+ FDB LIT8
+ FCB 7
+ FDB PLUS
+DIG2 FDB LIT8
+ FCC "0" ascii zero
+ FDB PLUS,HOLD
+ FDB SEMIS
+*
+* ======>> 213 <<
+* ( d --- dzero )
+* Convert d to a numeric string using # until the result is zero.
+* Leave the double result on the stack for #> to drop.
+ FCB $82
+ FCC '#' ; '#S'
+ FCB $D3
+ FDB DIG-4
+DIGS FDB DOCOL
+DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
+ FDB DIGS2-*-NATWID
+ FDB SEMIS
+*
+* ######>> screen 76 <<
+* ======>> 214 <<
+* ( n width --- )
+* Print n on the output device in the current conversion base,
+* with sign,
+* right aligned in a field at least width wide.
+ FCB $82
+ FCC '.' ; '.R'
+ FCB $D2
+ FDB DIGS-5
+DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
+ FDB SEMIS
+*
+* ======>> 215 <<
+* ( d width --- )
+* Print d on the output device in the current conversion base,
+* with sign,
+* right aligned in a field at least width wide.
+ FCB $83
+ FCC 'D.' ; 'D.R'
+ FCB $D2
+ FDB DOTR-5
+DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
+ FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
+ FDB SEMIS
+*
+* ======>> 216 <<
+* D. ( d --- )
+* Print d on the output device in the current conversion base,
+* with sign,
+* in free format with trailing space.
+ FCB $82
+ FCC 'D' ; 'D.'
+ FCB $AE
+ FDB DDOTR-6
+DDOT FDB DOCOL,ZERO,DDOTR,SPACE
+ FDB SEMIS
+*
+* ======>> 217 <<
+* ( n --- )
+* Print n on the output device in the current conversion base,
+* with sign,
+* in free format with trailing space.
+ FCB $81 .
+ FCB $AE
+ FDB DDOT-5
+DOT FDB DOCOL,STOD,DDOT
+ FDB SEMIS
+*
+* ======>> 218 <<
+* ( adr --- )
+* Print signed word at adr, per DOT.
+ FCB $81 ?
+ FCB $BF
+ FDB DOT-4
+QUEST FDB DOCOL,AT,DOT
+ FDB SEMIS
+*
+* ######>> screen 77 <<
+* ======>> 219 <<
+* ( n --- )
+* Print out screen n as a field of ASCII,
+* with line numbers in decimal.
+* Needs a console more than 70 characters wide.
+ FCB $84
+ FCC 'LIS' ; 'LIST'
+ FCB $D4
+ FDB QUEST-4
+LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
+ FCB 6
+ FCC "SCR # "
+ FDB DOT,LIT8
+ FCB $10
+ FDB ZERO,XDO
+LIST2 FDB CR,I,THREE
+ FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
+ FDB LIST2-*-NATWID
+ FDB CR
+ FDB SEMIS
+*
+* ======>> 220 <<
+* ( start end --- )
+* Print comment lines (line 0, and line 1 if C/L < 41) of screens
+* from start to end.
+* Needs a console more than 70 characters wide.
+ FCB $85
+ FCC 'INDE' ; 'INDEX'
+ FCB $D8
+ FDB LIST-7
+INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
+INDEX2 FDB CR,I,THREE
+ FDB DOTR,SPACE,ZERO,I,DLINE
+ FDB QTERM,ZBRAN
+ FDB INDEX3-*-NATWID
+ FDB LEAVE
+INDEX3 FDB XLOOP
+ FDB INDEX2-*-NATWID
+ FDB SEMIS
+*
+* ======>> 221 <<
+* ( n --- )
+* List a printer page full of screens.
+* Line and screen number are in current base.
+* Needs a console more than 70 characters wide.
+ FCB $85
+ FCC 'TRIA' ; 'TRIAD'
+ FCB $C4
+ FDB INDEX-8
+TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
+ FDB THREE,OVER,PLUS,SWAP,XDO
+TRIAD2 FDB CR,I
+ FDB LIST,QTERM,ZBRAN
+ FDB TRIAD3-*-NATWID
+ FDB LEAVE
+TRIAD3 FDB XLOOP
+ FDB TRIAD2-*-NATWID
+ FDB CR,LIT8
+ FCB $0F
+ FDB MESS,CR
+ FDB SEMIS
+*
+* ######>> screen 78 <<
+* ======>> 222 <<
+* ( --- )
+* Alphabetically list the definitions in the current vocabulary.
+* Expects to output to printer, not TRS80 Color Computer screen.
+ FCB $85
+ FCC 'VLIS' ; 'VLIST'
+ FCB $D4
+ FDB TRIAD-8
+VLIST FDB DOCOL,LIT8
+ FCB $80
+ FDB OUT,STORE,CONTXT,AT,AT
+VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
+ FCB 32
+ FDB SUB,GREAT,ZBRAN
+ FDB VLIST2-*-NATWID
+ FDB CR,ZERO,OUT,STORE
+VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
+ FDB DUP,ZEQU,QTERM,OR,ZBRAN
+ FDB VLIST1-*-NATWID
+ FDB DROP
+ FDB SEMIS
+*
+* Need some utility stuff that isn't in the fig FORTH:
+* ( c --- )
+* Emit dot if c is less than blank, else emit c
+ FCB $85
+ FCC 'BEMI' ; 'BEMIT'
+ FCB $D4 ; 'T'
+ FDB VLIST-8
+BEMIT FDB DOCOL
+ FDB DUP,BL,LESS,ZBRAN
+ FDB BEMITO-*-NATWID
+ FDB DROP,LIT8
+ FCB $2e ; '.'
+BEMITO FDB EMIT
+ FDB SEMIS
+*
+* ( n width --- )
+* Output n in hexadecimal field width.
+ FCB $83
+ FCC 'X.' ; 'X.R'
+ FCB $D2 ; 'R'
+ FDB BEMIT-8
+XDOTR FDB DOCOL
+ FDB BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
+ FDB SEMIS
+*
+* ( adr --- )
+* Dump a line of 4 bytes in memory, in hex and as characters.
+ FCB $85
+ FCC 'BLIN' ; 'BLINE'
+ FCB $C5 ; 'E'
+ FDB XDOTR-6
+BLINE FDB DOCOL
+ FDB DUP,LIT8
+ FCB 4
+ FDB PLUS,OVER,XDO
+BLINEX FDB I,CAT,THREE,XDOTR,XLOOP
+ FDB BLINEX-*-NATWID
+ FDB SPACE,SPACE
+ FDB DUP,LIT8
+ FCB 4
+ FDB PLUS,SWAP,XDO
+BLINEC FDB I,CAT,BEMIT,XLOOP
+ FDB BLINEC-*-NATWID
+ FDB SEMIS
+*
+* ( start end --- )
+* Dump 4 byte lines from start to end.
+ FCB $85
+ FCC 'BDUM' ; 'BDUMP'
+ FCB $D0 ; '5'
+ FDB BLINE-8
+BDUMP FDB DOCOL
+ FDB CR,XDO
+BDUMPL FDB I,LIT8
+ FCB 4
+ FDB XDOTR,LIT8
+ FCB $3A
+ FDB EMIT,SPACE
+ FDB I,BLINE,CR,LIT8
+ FCB 4
+ FDB XPLOOP
+ FDB BDUMPL-*-NATWID
+ FDB SEMIS
+*
+* ======>> XX <<
+* ( --- )
+* Mostly for place holding (fig Forth).
+ FCB $84
+ FCC 'NOO' ; 'NOOP'
+ FCB $D0
+ FDB BDUMP-8
+NOOP FDB *+NATWID
+ LBRA NEXT
+* NOOP NEXT a useful no-op
+ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
+
+ PAGE
+* These things, up through the lable 'REND', are overwritten
+* at time of cold load and should have the same contents
+* as shown here:
+*
+* This can be moved whereever the bottom of the
+* user's dictionary is going to be put.
+*
+RBEG EQU *
+ FCB $C5 immediate
+ FCC 'FORT' ; 'FORTH'
+ FCB $C8
+ FDB NOOP-7
+FORTH FDB DODOES,DOVOC,$81A0,TASK-7
+ FDB 0
+*
+ FCC "Copyright 1979 Forth Interest Group, David Lion,"
+ FCB $0D
+ FCC "Parts Copyright 2019 Joel Matthew Rees"
+ FCB $0D
+*
+ FCB $84
+ FCC 'TAS' ; 'TASK'
+ FCB $CB
+ FDB FORTH-8
+TASK FDB DOCOL,SEMIS
+*
+REND EQU * ( first empty location in dictionary )
+RSIZE EQU *-RBEG ; So we can look at it.
+ PAGE
+
+ ORG RAMDSK
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " 0) Index page " ; 0
+ FCC " 1) empty line on line 1 of screen 0 block 0 " ; 1
+ FCC " 2) Title and copyright " ; 2
+ FCC " 3) empty line on line 3 of screen 0 block 0 " ; 3
+ FCC " 4) Error messages 1st screen " ; 4
+ FCC " 5) Error messages 2nd screen " ; 5
+ FCC " 6) empty line 3 screen 0 block 1 " ; 6
+ FCC " 7) empty line 4 " ; 7
+ FCC " 8) and line 1 of block 2 " ; 8
+ FCC " 9) line 2 of block 2 screen 0 is pretty much empty too " ; 9
+ FCC " 10) listen to this. Line three of block two is too " ; 10
+ FCC " 11) and so is line 4 4 4 4 4 4 4 4 4 4 b2s0 " ; 11
+ FCC " 12) screen zero block three first line " ; 12
+ FCC " 13) second line fourth block (block three) screen 0 " ; 13
+ FCC " 14) block three screen zero line 3 3 3 3 3 3 3 3 3 " ; 14
+ FCC " 15) fourth line block three screen 0 0 0 0 0 0 0 0 0 0 " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " test 10 b0s1 aaaa " ; 0
+ FCC " test 11 b0s1 ee ee ee ee " ; 1
+ FCC " test 12 b0s1 oo oo oo oo oo " ; 2
+ FCC " test 13 b0s1 eh ehe he eh eh " ; 3
+ FCC " ( block 1 ) b1s1 oh ohoo oh oh oh " ; 4
+ FCC " 15 test b1s1 " ; 5
+ FCC " 16 test b1s1 " ; 6
+ FCC " 17 test b1s1 " ; 7
+ FCC " 18 test b2s1 " ; 8
+ FCC " 19 test b2s1 " ; 9
+ FCC " 1A test b2s1 " ; 10
+ FCC " 1B test b2ws1 " ; 11
+ FCC " 1C test b3s1 " ; 12
+ FCC " 1D test b3s1 " ; 13
+ FCC " 1e this completes our second screen b3s1 " ; 14
+ FCC " 1F test b3s1 " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " " ; 0
+ FCC " fig Forth High Level Model Code " ; 1
+ FCC " " ; 2
+ FCC " Copyright 2018 Joel Matthew Rees " ; 3
+ FCC " ( block 2 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " " ; 0
+ FCC " " ; 1
+ FCC " " ; 2
+ FCC " " ; 3
+ FCC " ( block 3 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " " ; 0
+ FCC " " ; 1
+ FCC " " ; 2
+ FCC " " ; 3
+ FCC " ( block 4 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " ( ERROR MESSAGES ) " ; 0
+ FCC " DATA STACK UNDERFLOW " ; 1
+ FCC " DICTIONARY FULL " ; 2
+ FCC " ADDRESS RESOLUTION ERROR " ; 3
+ FCC " HIDES DEFINITION IN " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " more test data 2 3 4 5 6 " ; 0
+ FCC "0123456789012345678901234567890123456789012345678901234567890123" ; 1
+ FCC "Test data for the RAM disc emulator buffers. " ; 2
+ FCC " " ; 3
+ FCC " ( block 6 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " end" ; 15
+RAMDND EQU *
+
+
+ PAGE
+ OPT L
+ END
--- /dev/null
+ OPT PRT
+
+* fig-FORTH FOR 6809
+* ASSEMBLY SOURCE LISTING
+
+* RELEASE 0
+* JAN 2019
+* WITH COMPILER SECURITY
+* AND VARIABLE LENGTH NAMES
+* Using RTS mode
+*
+* Adapted by Joel Matthew Rees
+* from fig-FORTH for 6800 by Dave Lion, et. al.
+
+* This free/libre/open source publication is provided
+* through the courtesy of:
+* FORTH
+* INTEREST
+* GROUP
+* fig
+* and other interested parties.
+
+* Ancient address:
+* P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
+* URL: http://www.forth.org
+* Further distribution must include this notice.
+ PAGE
+ NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
+ OPT NOG,PAG
+* filename fig-forth-auto6809opt.asm
+* === FORTH-6809 {date} {time}
+
+
+* Permission is hereby granted, free of charge, to any person obtaining a copy
+* of this software and associated documentation files (the "Software"), to deal
+* in the Software without restriction, including without limitation the rights
+* to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+* copies of the Software, and to permit persons to whom the Software is
+* furnished to do so, subject to the following conditions:
+*
+* The above copyright notice and this permission notice shall be included in
+* all copies or substantial portions of the Software.
+
+* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+* THE SOFTWARE.
+*
+* "Associated documentation" for this declaration of license
+* shall be interpreted to include only the comments in this file,
+* or, if the code is split into multiple files,
+* all files containing the complete source.
+*
+* This is the MIT model license, as published by the Open Source Consortium,
+* with associated documentation defined.
+* It was chosen to reflect the spirit of the original
+* terms of use, which used archaic legal terminology.
+*
+
+* Authors of the 6800 model:
+* === Primary: Dave Lion,
+* === with help from
+* === Bob Smith,
+* === LaFarr Stuart,
+* === The Forth Interest Group
+* === PO Box 1105
+* === San Carlos, CA 94070
+* === and
+* === Unbounded Computing
+* === 1134-K Aster Ave.
+* === Sunnyvale, CA 94086
+*
+NATWID EQU 2 ; bytes per natural integer/pointer
+* The original version was developed on an AMI EVK 300 PROTO
+* system using an ACIA for the I/O.
+* This version is developed targeting the Tandy Color Computer.
+
+* All terminal 1/0
+* is done in three subroutines:
+* PEMIT ( word # 182 )
+* PKEY ( 183 )
+* PQTERM ( 184 )
+*
+* The FORTH words for disc related I/O follow the model
+* of the FORTH Interest Group, but have not yet been
+* tested using a real disc.
+*
+* Addresses in the 6800 implementation reflect the fact that,
+* on the development system, it was convenient to
+* write-protect memory at hex 1000, and leave the first
+* 4K bytes write-enabled. As a consequence, code from
+* location $1000 to lable ZZZZ could be put in ROM.
+* Minor deviations from the model were made in the
+* initialization and words ?STACK and FORGET
+* in order to do this.
+* Those deviations will be altered in this
+* implementation for the 6809 -- Color Computer.
+*
+
+* MEMORY MAP for this 16K|32K system:
+* ( delineated so that systems with 4k byte write-
+* protected segments can write protect FORTH )
+*
+* addr. contents pointer init by
+* **** ******************************* ******* ******
+*
+* Coco has no ACIA!
+* ACIAC EQU $FBCE the ACIA control address and
+* ACIAD EQU ACIAC+1 data address for PROTO
+*
+MEMT32 EQU $7FFF ; Theoretical absolute end of all ram
+MEMT16 EQU $3FFF ; 16K is too tight until we no longer need disc emulation.
+MEMTOP EQU MEMT32
+*
+MASSHI EQU MEMTOP
+*
+* 3FFF|7FFF HI
+*
+* substitute for disc mass memory
+RAMSCR EQU 8 ; addresses calculate as 2 (Too much for 16K in RAM only.)
+SCRSZ EQU 1024
+* 3800|7800 LO
+MASSLO EQU MASSHI-RAMSCR*SCRSZ+1
+RAMDSK EQU MASSLO
+MEMEND EQU MASSLO
+*
+* 3800|7800 MEMEND
+* "end" of "usable ram" (If disc mass memory emulation is removed, actual end.)
+*
+* 37FF|77FF
+*
+* per-user tables
+USERSZ EQU 256 ; (Addressable by DP, must be 256 on even boundary)
+USER16 EQU 1 ; We can change these for ROMPACK or 64K.
+USER32 EQU 2 ; maybe?
+USERCT EQU USER32
+USERLO EQU MEMEND-USERSZ*USERCT
+IUP EQU USERLO
+IUPDP EQU IUP/256
+* user tables of variables
+* registers & pointers for the virtual machine
+* scratch area for potential use in something, maybe?
+*
+* 3700|7600 <== UP
+*
+* This is a really awkward place to define the disk buffer records.
+*
+* 4 buffer sectors of VIRTUAL MEMORY
+NBLK EQU 4 ; # of disc buffer blocks for virtual memory
+* Should NBLK be SCRSZ/SECTSZ?
+* each block is SECTSZ+SECTRL bytes in size,
+* holding SECTSZ characters
+SECTSZ EQU 256
+SECTRL EQU 2*NATWID ; Currently held sector number, etc.
+BUFSZ EQU (SECTSZ+SECTRL)*NBLK
+BUFBAS EQU USERLO-BUFSZ
+* *BUG* SECTRL is hard-wired into several definitions.
+* It will take a bit of work to ferret them out.
+* It is too small, and it should not be hard-wired.
+* SECTSZ was also hard-wired into several definitions,
+* will I find them all?
+*
+* 32E0|71E0 FIRST
+*
+ PAGE
+*
+* Don't want one return too many to destroy the disc buffers.
+RPBUMP EQU 4*NATWID
+*
+* 32D8|71D8 <== RP RINIT
+*
+IRP EQU BUFBAS-RPBUMP
+* RETURN STACK
+RSTK16 EQU $50*NATWID ; 80 max levels nesting calls
+RSTK32 EQU $90*NATWID ; 144 max
+RSTKSZ EQU RSTK32
+*
+* 3248|70B8
+*
+SFTBND EQU IRP-RSTKSZ ; (false boundary between TIB and return stack)
+* INPUT LINE BUFFER
+* holds up to TIBSZ characters
+* and is scanned upward by IN
+* starting at TIB
+TIBSZ EQU 256
+ITIB EQU SFTBND-TIBSZ
+*
+* 3148|6FB8 <== IN TIB
+*
+* Don't want terminal input and parameter underflow collisions
+SPBUMP EQU 4*NATWID
+*
+ISP EQU ITIB-SPBUMP
+*
+* 3140|6FB0 <== SP SP0,SINIT
+* DATA STACK
+* | grows downward from 3140|6FB0
+* v
+* - -
+* ^
+* |
+* I DICTIONARY grows upward
+*
+* >>>>>>--------Two words to start RAMmable dictionary--------<<<<<<
+*
+* (2B00)
+* ???? end of ram-dictionary. <== DICTPT DPINIT
+* "TASK"
+*
+* ???? "FORTH" ( a word ) <=, <== CONTEXT
+* `==== CURRENT
+* start of ram-dictionary.
+*
+* >>>>>> memory from here up must be in RAM area <<<<<<
+*
+* ????
+* 6k of romable "FORTH" <== IP ABORT
+* <== W
+* the VIRTUAL FORTH MACHINE
+*
+* 1208 initialization tables
+* 1204 <<< WARM START ENTRY >>>
+* 1200 <<< COLD START ENTRY >>>
+* 1200 lowest address used by FORTH
+*
+CODEBG EQU $1200
+* CODEBG EQU $3000
+*
+* >>>>>> memory from here down left alone <<<<<<
+* >>>>>> so we can safely call ROM routines <<<<<<
+*
+* 0000
+ PAGE
+***
+*
+* CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
+*
+* IP (hardware Y) points to the current instruction ( pre-increment mode )
+* RP (hardware S) points to last return address pushedin return stack
+* SP (hardware U) points to last byte pushed in data stack
+*
+* Y must be IP when NEXT is entered (if using the inner loop).
+*
+* When A and B hold one 16 bit FORTH data word,
+* A contains the high byte, B, the low byte.
+*
+* UP (hardware DP) is the base of per-task ("user") variables.
+* (Be careful of the stray semantics of "user".)
+*
+* W (hardware X) is the pointer to the "code field" address of native CPU
+* machine code to be executed for the definition of the dictionary word
+* to be executed/currently executing.
+* The following natural integer (word) begins any "parameter section"
+* (body) -- similar to a "this" pointer, but not the same.
+* It may be native CPU machine code, or it may be a global variable,
+* or it may be a list of Forth definition words (addresses).
+*
+* ======
+* This implementation uses the native subroutine architecture
+* rather than a postponed-push call that the 6800 model VM uses
+* to save code and time in leaf routines.
+*
+* This should allow directly calling many of the Forth words
+* from assembly language code.
+* (Be aware of the need for a valid W in some cases.)
+* It won't allow mixing assembly language directly into Forth word lists.
+* ======
+*
+* boolean flags:
+* 0 is false, anything else is true.
+* Most places in this model that set a boolean flag set true as 1.
+* This is in contrast to many models that set a boolean flag as -1.
+*
+***
+
+ PAGE
+* This system is shown with one user (task),
+* but additional users (tasks) may be added
+* by allocating additional user tables:
+*
+ ORG IUP
+UBASE RMB USERSZ
+UBASEX RMB USERSZ data table for extra users
+*
+* Some of this stuff gets initialized during
+* COLD start and WARM start:
+* [ names correspond to FORTH words of similar (no X) name ]
+*
+ ORG IUP
+UORIG EQU *
+* A few useful VM variables
+* Will be removed when they are no longer needed.
+* All are replaced by 6809 registers.
+
+N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
+* SP@,SWAP,DOES>,COLD
+
+
+* These locations are used by the TRACE routine :
+
+TRLIM RMB 1 the count for tracing without user intervention
+TRACEM RMB 1 non-zero = trace mode
+BRKPT RMB 2 the breakpoint address at which
+* the program will go into trace mode
+VECT RMB 2 vector to machine code
+* (only needed if the TRACE routine is resident)
+
+
+* Registers used by the FORTH virtual machine:
+* Starting at $OOFO:
+
+
+W RMB 2 the instruction register points to 6800 code
+* This is not exactly accurate. Points to the definiton body,
+* which is native CPU machine code when it is native CPU machine code.
+* IP RMB 2 the instruction pointer points to pointer to 6800 code
+* RP RMB 2 the return stack pointer
+* UP RMB 2 the pointer to base of current user's 'USER' table
+* ( altered during multi-tasking )
+*
+*UORIG RMB 6 3 reserved variables
+ RMB 6 3 reserved variables
+XSPZER RMB 2 initial top of data stack for this user
+XRZERO RMB 2 initial top of return stack
+XTIB RMB 2 start of terminal input buffer
+XWIDTH RMB 2 name field width
+XWARN RMB 2 warning message mode (0 = no disc)
+XFENCE RMB 2 fence for FORGET
+XDICTP RMB 2 dictionary pointer
+XVOCL RMB 2 vocabulary linking
+XBLK RMB 2 disc block being accessed
+XIN RMB 2 scan pointer into the block
+XOUT RMB 2 cursor position
+XSCR RMB 2 disc screen being accessed ( O=terminal )
+XOFSET RMB 2 disc sector offset for multi-disc
+XCONT RMB 2 last word in primary search vocabulary
+XCURR RMB 2 last word in extensible vocabulary
+XSTATE RMB 2 flag for 'interpret' or 'compile' modes
+XBASE RMB 2 number base for I/O numeric conversion
+XDPL RMB 2 decimal point place
+XFLD RMB 2
+XCSP RMB 2 current stack position, for compile checks
+XRNUM RMB 2
+XHLD RMB 2
+XDELAY RMB 2 carriage return delay count
+XCOLUM RMB 2 carriage width
+IOSTAT RMB 2 last acia status from write/read
+ RMB 2 ( 4 spares! )
+ RMB 2
+ RMB 2
+ RMB 2
+
+
+
+
+*
+*
+* end of user table, start of common system variables
+*
+*
+*
+* These need to be moved to where they will be
+* initialized globals in variable space, not in the USER table.
+* Or, more accurately, need to be turned into monitored or semaphored resources.
+XUSE RMB 2
+XPREV RMB 2
+ RMB 4 ( spares )
+
+ PAGE
+* The FORTH program ( address $1200 to about $27FF ) will be written
+* so that it can be in a ROM, or write-protected if desired,
+* but right now we're just getting it running.
+ ORG CODEBG
+
+* ######>> screen 3 <<
+*
+***************************
+** C O L D E N T R Y **
+***************************
+ORIG NOP
+* JMP CENT
+ LBSR CENT
+***************************
+** W A R M E N T R Y **
+***************************
+ NOP
+* JMP WENT warm-start code, keeps current dictionary intact
+ LBSR WENT warm-start code, keeps current dictionary intact
+ SETDP IUPDP
+
+*
+******* startup parmeters **************************
+*
+ FDB $6809,0000 cpu & revision
+ FDB 0 topmost word in FORTH vocabulary
+* BACKSP FDB $7F backspace character for editing
+BACKSP FDB $08 backspace character for editing
+UPINIT FDB UORIG initial user area
+* UPINIT FDB UORIG initial user area
+SINIT FDB ISP ; initial top of data stack
+* SINIT FDB ORIG-$D0 initial top of data stack
+RINIT FDB IRP ; initial top of return stack
+* RINIT FDB ORIG-2 initial top of return stack
+ FDB ITIB ; terminal input buffer
+* FDB ORIG-$D0 terminal input buffer
+ FDB 31 initial name field width
+ FDB 0 initial warning mode (0 = no disc)
+FENCIN FDB REND initial fence
+DPINIT FDB REND cold start value for DICTPT
+BUFINT FDB BUFBAS Start of the disk buffers area
+VOCINT FDB FORTH+4*NATWID
+COLINT FDB TIBSZ initial terminal carriage width
+DELINT FDB 4 initial carriage return delay
+****************************************************
+*
+ PAGE
+*
+* ######>> screen 13 <<
+* These were of questionable use anyway,
+* kept here now to satisfy the assembler and show hints.
+* They're too much trouble to use with native subroutine call anyway.
+* PULABX PULS A ; 24 cycles until 'NEXT'
+* PULS B ;
+* PULABX PULU A,B ; ?? cycles until 'NEXT'
+* STABX STA 0,X 16 cycles until 'NEXT'
+* STB 1,X
+* STABX STD 0,X ; ?? cycles until 'NEXT'
+ BRA NEXT
+* GETX LDA 0,X 18 cycles until 'NEXT'
+* LDB 1,X
+* GETX LDD 0,X ?? cycles until 'NEXT'
+* PUSHBA PSHS B ; 8 cycles until 'NEXT'
+* PSHS A ;
+* PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
+
+
+*
+* "NEXT" takes ?? cycles if TRACE is removed,
+*
+* and ?? cycles if trace is present and NOT tracing.
+*
+* = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
+* =
+* NEXT itself might just completely go away.
+* About the only reason to keep it is to allowing executing a list
+* which allows a cheap TRACE routine.
+*
+* NEXT is a loop which implements the Forth VM.
+* It basically cycles through calling the code out of code lists,
+* one at a time.
+* Using a native CPU return for this uses a few extra cycles per call,
+* compared to simply jumping to each definition and jumping back
+* to the known beginning of the loop,
+* but the loop itself is really only there for convenience.
+*
+* This implementation uses the native subroutine call,
+* to break the wall between Forth code and non-Forth code.
+*
+* NEXT LDX IP
+* LEAX 1,X ; pre-increment mode
+* LEAX 1,X ;
+* STX IP
+NEXT ; IP is Y, push before using, pull before you come back here.
+*
+* NEXT2 LDX 0,X get W which points to CFA of word to be done
+NEXT2 LDX ,Y++ get W which points to CFA of word to be done
+* BSR DBGNAM
+* BSR DBGREG
+* But NEXT2 is too much trouble to use with subroutine threading anyway.
+* NEXT3 STX W
+NEXT3 ; W is X until you use X for something else. (TOS points back here.)
+* But NEXT3 is too much trouble to use with subroutine threading anyway.
+* LDX 0,X get VECT which points to executable code
+* =
+* The next instruction could be patched to JMP TRACE =
+* if a TRACE routine is available: =
+* =
+* JMP 0,X
+
+ JSR [,X] ; Saving the postinc cycles,
+* ; but X must be bumped NATWID to the parameters.
+* NOP
+* JMP TRACE ( an alternate for the above )
+* BSR DBGREG ( an alternate for the above )
+* In other words, with the call and the NOP,
+* there is room to patch the call with a JMP to your TRACE
+* routine, which you have to provide.
+ BRA NEXT
+*
+DBGNAM PSHS CC,D,X,Y
+ TST <TRACEM
+ BEQ DBGNrt
+ LEAX -3,X
+DBGNlf LDB ,-X
+ BPL DBGNlf
+ LDY #$4C0
+ LDB ,X+
+DBGNlp LDB ,X+
+ BMI DBGNll
+ STB ,Y+
+ BRA DBGNlp
+DBGNll ANDB #$7F
+ STB ,Y+
+ LDB #$60
+ BRA DBGNlt
+DBGNlc STB ,Y+
+DBGNlt CMPY #$4E0
+ BLO DBGNlc
+DBGNrt PULS CC,D,X,Y,PC
+*
+*
+MKhxBh LSRB
+ LSRB
+ LSRB
+ LSRB
+MKhxBl ANDB #$0F
+ ADDB #$30
+ CMPB #$39
+ BLS MKhxBx
+ ADDB #$C7 ; ($40-$39)-$40
+MKhxBx RTS
+*
+OUThxA EXG A,B
+ BSR OUThxB
+ EXG A,B
+ RTS
+*
+OUThxD BSR OUThxA
+OUThxB PSHS B
+ BSR MKhxBh
+ STB ,X+
+ LDB ,S
+ BSR MKhxBl
+ STB ,X+
+ PULS B,PC
+*
+DBGREG PSHS U,Y,X,DP,B,A,CC
+ TST <TRACEM
+ LBEQ DBGRrt
+ LEAY DBGRLB,PCR
+ LDX #$4E0
+DBGRlp LDD ,Y++
+ BEQ DBGRdn
+ STD ,X++
+ BRA DBGRlp
+DBGRdn LDX #$500
+ LDA 3,S ; DP
+ LDB ,S ; CC
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 3*NATWID+4,S ; PC:505
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ TFR S,D ; 509
+ ADDD #4*NATWID+4
+ BSR OUThxD
+ LDD 2*NATWID+4,S ; U:50E
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 1*NATWID+4,S ; Y:513
+ BSR OUThxD
+ LDD 0*NATWID+4,S ; X at 517
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 1,S ; D at 51C
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ LDD [3*NATWID+4,S] ; PC
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 4*NATWID+4,S ; S
+ BSR OUThxD
+ LDD [2*NATWID+4,S] ; U
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD [1*NATWID+4,S] ; Y
+ LBSR OUThxD
+ LDD [0*NATWID+4,S] ; X
+ LBSR OUThxD
+ LDB #$60
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ LDB #0
+ EXG B,DP
+DBGRkl JSR [$A000]
+ BEQ DBGRkl
+ STD $43E
+ EXG DP,B
+ CMPA #$55 ; 'U'
+ BEQ DBGRdU
+ CMPA #$53 ; 'S'
+ BEQ DBGRdS
+ CMPA #$49 ; 'I'
+ LBNE 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
+ LDD ,Y++
+ LBSR OUThxA
+ LDA #$9F
+ STA ,X+
+ LBSR OUThxB
+ LDD ,Y++
+ LBSR OUThxA
+ LDA #$9F
+ STA ,X+
+ LBSR OUThxB
+ LDA #$58 ; X
+ STA ,X+
+ LDD ,Y++
+ LBSR OUThxD
+ LDA #$59 ; Y
+ STA ,X+
+ LDD ,Y++
+ LBSR OUThxD
+ LDA #$55 ; U
+ STA ,X+
+ LDD ,Y++
+ LBSR OUThxD
+ LDA #$50 ; PC
+ STA ,X+
+ LDD ,Y++
+ LBSR OUThxD
+ LDA #$53 ; Stack
+ STA ,X+
+ 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
+ LDB #$FF
+ STB ,X+
+DBGRrt PULS CC,A,B,DP,X,Y,U,PC
+DBGRLB FCC 'DPCC PC S U Y X A B '
+ FDB 0,0
+
+
+*
+* =
+* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+
+
+ PAGE
+*
+* ======>> 1 <<
+* ( --- n )
+* Pushes the following natural width integer from the instruction stream
+* as a literal, or immediate value.
+*
+* FDB {OP}
+* FDB {OP}
+* FDB LIT
+* FDB LITERAL-TO-BE-PUSHED
+* FDB {OP}
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* (Note that there is no compile-only flag in the fig model.)
+*
+* See (FIND), or PFIND , for layout of the header format.
+*
+ FCB $83
+ FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
+ FCB $D4 ; 'T'|'\x80' ; character code for T, with high bit set.
+ FDB 0 ; link of zero to terminate dictionary scan
+LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
+ LDD ,Y++
+ PSHU A,B
+ RTS
+* LDX IP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX IP
+* LDA 0,X
+* LDB 1,X
+* JMP PUSHBA
+*
+* ######>> screen 14 <<
+* ======>> 2 <<
+* ( --- n )
+* Pushes the following byte from the instruction stream
+* as a literal, or immediate value.
+*
+* FDB {OP}
+* FDB {OP}
+* FDB LIT8
+* FCB LITERAL-TO-BE-PUSHED
+* FDB {OP}
+*
+* If this is kept, it should have a header for TRACE to read.
+* If the data bus is wider than a byte, you don't want to do this.
+* Byte shaving like this is often counter-productive anyway.
+* Changing the name to LIT8, hoping that will be more understandable.
+* Also, see comments for LIT.
+* (Note that there is no compile-only flag in the fig model.)
+ FCB $84
+ FCC 'LIT' ; 'LIT8' : NOTE: this is different from LITERAL
+ FCB $B8
+ FDB LIT-6
+LIT8 FDB *+NATWID (this was an invisible word, with no header)
+ LDB ,Y+ ; This also is meaningless in native code.
+ CLRA
+ PSHU A,B
+ RTS
+* LDX IP
+* LEAX 1,X ;
+* STX IP
+* CLRA ;
+* LDB 1,X
+* JMP PUSHBA
+*
+* ( n off --- n )
+* off is offset in video buffer area.
+ FCB $87
+ FCC 'SHOWTO' ; 'SHOWTOS'
+ FCB $D3 ; 'S'
+ FDB LIT8-7
+SHOTOS FDB *+NATWID
+ LDX #$400
+ LDD ,U++
+ LEAX D,X
+ LDD ,U
+ LBSR OUThxD
+ RTS
+*
+ FCB $85
+ FCC 'TROF' ; 'TROFF'
+ FCB $C6 ; 'F'|$80
+ FDB SHOTOS-10
+TROFF FDB *+NATWID
+ CLR <TRACEM
+ RTS
+*
+ FCB $84
+ FCC 'TRO' ; 'TRON'
+ FCB $CE ; 'N'|$80
+ FDB TROFF-8
+TRON FDB *+NATWID
+ INC <TRACEM
+ RTS
+*
+* ======>> 3 <<
+* ( adr --- )
+* Jump to address on stack. Used by the "outer" interpreter to
+* interactively invoke routines.
+* Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
+ FCB $87
+ FCC 'EXECUT' ; 'EXECUTE'
+ FCB $C5
+ FDB TRON-7
+EXEC FDB *+NATWID
+ PULU X ; Gotta have W anyway, just in case.
+ JMP [,X] ; Tail return.
+* TFR S,X ; TSX :
+* LDX 0,X get code field address (CFA)
+* LEAS 1,S ; pop stack
+* LEAS 1,S ;
+* JMP NEXT3
+*
+* ######>> screen 15 <<
+* ======>> 4 <<
+* ( --- ) C
+* Add the following word from the instruction stream to the
+* instruction pointer (Y++). Causes a program branch in Forth code stream.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $86
+ FCC 'BRANC' ; 'BRANCH'
+ FCB $C8
+ FDB EXEC-10
+BRAN FDB ZBYES ; Go steal code in ZBRANCH
+
+* Moving code around to optimize the branch taking case in 0BRANCH.
+ZBNO LEAY NATWID,Y ; No branch.
+ RTS
+* ======>> 5 <<
+* ( f --- ) C
+* BRANCH if flag is zero.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $87
+ FCC '0BRANC' ; '0BRANCH'
+ FCB $C8
+ FDB BRAN-9
+ZBRAN FDB *+NATWID
+ LDD ,U++
+ BNE ZBNO
+ZBYES LDD ,Y++
+ LEAY D,Y ; IP is postinc
+ RTS
+* PULS A ;
+* PULS B ;
+* PSHS B ; ** emulating ABA:
+* ADDA ,S+ ;
+* BNE ZBNO
+* BCS ZBNO
+* ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
+* LDB 3,X
+* LDA 2,X
+* ADDB IP+1
+* ADCA IP
+* STB IP+1
+* STA IP
+* JMP NEXT
+* ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
+* LEAX 1,X ; jump over branch delta
+* LEAX 1,X ;
+* STX IP
+* JMP NEXT
+*
+* ######>> screen 16 <<
+* ======>> 6 <<
+* ( --- ) ( limit index *** limit index+1) C
+* ( limit index *** )
+* Counting loop primitive. The counter and limit are the top two
+* words on the return stack. If the updated index/counter does
+* not exceed the limit, a branch occurs. If it does, the branch
+* does not occur, and the index and limit are dropped from the
+* return stack.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $86
+ FCC '(LOOP' ; '(LOOP)'
+ FCB $A9
+ FDB ZBRAN-10
+XLOOP FDB *+NATWID
+ LDD #1 ; Borrowing from BIF-6809.
+XLOOPA ADDD NATWID,S ; Dodge the return address.
+ STD NATWID,S
+ SUBD 2*NATWID,S
+ BMI ZBYES ; pseudo-signed-unsigned
+XLOOPN LEAY NATWID,Y
+ LDX ,S ; synthetic return
+ LEAS 3*NATWID,S ; Clean up the index and limit.
+ JMP ,X
+* CLRA ;
+* LDB #1 get set to increment counter by 1 (Clears N.)
+* BRA XPLOP2 go steal other guy's code!
+*
+* ======>> 7 <<
+* ( n --- ) ( limit index *** limit index+n ) C
+* ( limit index *** )
+* Loop with a variable increment. Terminates when the index
+* crosses the boundary from one below the limit to the limit. A
+* positive n will cause termination if the result index equals the
+* limit. A negative n must cause the index to become less than
+* the limit to cause loop termination.
+*
+* Note that the end conditions are not symmetric around zero.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $87
+ FCC '(+LOOP' ; '(+LOOP)'
+ FCB $A9
+ FDB XLOOP-9
+XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
+ LDD ,U++ ; inc val
+ BPL XLOOPA ; Steal plain loop code for forward count.
+ ADDD NATWID,S ; Dodge the return address
+ STD NATWID,S
+ SUBD 2*NATWID,S
+ BPL ZBYES ; pseudo-signed-unsigned
+ BRA XLOOPN ; This path might be less time-sensitive.
+*
+* This should work, but I want to use tested code.
+* PULU A,B ; Get the increment.
+* XPLOP2 PULS X ; Pre-clear the return stack.
+* PSHU A ; Save the direction in high bit.
+* ADDD ,S ; Count.
+* STD ,S ; Update.
+* SUBD NATWID,S ; Check limit.
+**
+** I think this should work:
+* EORA ,U+ ; dir < 0 and (count - limit) >= 0
+* BPL XPLONO ; or dir >= 0 and (count - limit) < 0
+* LDD ,Y++
+* LEAY D,Y ; IP is postinc
+* JMP ,X
+* XPLONO LEAS 2*NATWID,S
+* JMP ,X ; synthetic return
+*
+* This definitely should work:
+* TST ,U+ ; Get the sign
+* BPL XPLOF ;
+* CMPD NATWID,S
+* BMI XPLONO
+* XPLOYE LDD ,Y++
+* LEAY D,Y ; IP is postinc
+* JMP ,X
+* XPLOF CMPD NATWID,S
+* BMI XPLOYE
+* XPLONO LEAS 2*NATWID,S
+* JMP ,X ; synthetic return
+*
+* 6800 Probably could have used the exclusive-or method, too.:
+* PULS A ; get increment
+* PULS B ;
+* XPLOP2 TSTA ;
+* BPL XPLOF forward looping
+* BSR XPLOPS
+* ORCC #$01 ; SEC :
+* SBCB 5,X
+* SBCA 4,X
+* BPL ZBYES
+* BRA XPLONO fall through
+*
+* the subroutine :
+* XPLOPS LDX RP
+* ADDB 3,X add it to counter
+* ADCA 2,X
+* STB 3,X store new counter value
+* STA 2,X
+* RTS
+*
+* XPLOF BSR XPLOPS
+* SUBB 5,X
+* SBCA 4,X
+* BMI ZBYES
+*
+* XPLONO LEAX 1,X ; done, don't branch back
+* LEAX 1,X ;
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX RP
+* BRA ZBNO use ZBRAN to skip over unused delta
+*
+* ######>> screen 17 <<
+* ======>> 8 <<
+* ( limit index --- ) ( *** limit index )
+* Move the loop parameters to the return stack. Synonym for D>R.
+ FCB $84
+ FCC '(DO' ; '(DO)'
+ FCB $A9
+ FDB XPLOOP-10
+XDO FDB *+NATWID This is the RUNTIME DO, not the COMPILING DO
+ LDX ,S ; Save the return address.
+ PULU A,B
+ PSHS A,B
+ PULU A,B ; Maintain order.
+ STD NATWID,S
+ JMP ,X ; synthetic return
+*
+* LDX RP
+* LEAX -1,X ;
+* LEAX -1,X ;
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* PULS A ;
+* PULS B ;
+* STA 2,X
+* STB 3,X
+* PULS A ;
+* PULS B ;
+* STA 4,X
+* STB 5,X
+* JMP NEXT
+*
+* ======>> 9 <<
+* ( --- index ) ( limit index *** limit index )
+* Copy the loop index from the return stack. Synonym for R.
+ FCB $81 I
+ FCB $C9
+ FDB XDO-7
+I FDB *+NATWID
+ LDD NATWID,S ; Dodge return address.
+ PSHU A,B
+ RTS
+* LDX RP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* JMP GETX
+*
+* ######>> screen 18 <<
+* ======>> 10 <<
+* ( c base --- false )
+* ( c base --- n true )
+* Translate C in base, yielding a translation valid flag. If the
+* translation is not valid in the specified base, only the false
+* flag is returned.
+ FCB $85
+ FCC 'DIGI' ; 'DIGIT'
+ FCB $D4
+ FDB I-4
+DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
+ LDD NATWID,U ; Check the whole thing.
+ SUBD #$30 ; ascii zero
+ BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+ CMPD #$A
+ BMI DIGIT0 IF '9' OR LESS
+ CMPD #$11
+ BMI DIGIT2 if less than 'A'
+ CMPD #$2B
+ BPL DIGIT2 if greater than 'Z'
+ SUBD #7 translate 'A' thru 'F'
+DIGIT0 CMPD ,U ; Check the base.
+ BPL DIGIT2 if not less than the base
+ STD NATWID,U ; Store converted digit. (High byte known zero.)
+ LDD #1 ; set valid flag
+DIGIT1 STD ,U ; store the flag
+ RTS NEXT
+DIGIT2 LDD #0 ; set not valid flag
+ LEAU NATWID,U ; pop base
+ BRA DIGIT1
+* TFR S,X ; TSX :
+* LDA 3,X
+* SUBA #$30 ascii zero
+* BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+* CMPA #$A
+* BMI DIGIT0 IF '9' OR LESS
+* CMPA #$11
+* BMI DIGIT2 if less than 'A'
+* CMPA #$2B
+* BPL DIGIT2 if greater than 'Z'
+* SUBA #7 translate 'A' thru 'F'
+* DIGIT0 CMPA 1,X
+* BPL DIGIT2 if not less than the base
+* LDB #1 set flag
+* STA 3,X store digit
+* DIGIT1 STB 1,X store the flag
+* JMP NEXT
+* DIGIT2 CLRB ;
+* LEAS 1,S ;
+* LEAS 1,S ; pop bottom number
+* TFR S,X ; TSX :
+* STB 0,X make sure both bytes are 00
+* BRA DIGIT1
+*
+* ######>> screen 19 <<
+*
+* The word definition format in the dictionary:
+*
+* (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
+*
+* NFA (name field address):
+* char-count + $80 Length of symbol name, flagged with high bit set.
+* char 1 Characters of symbol name.
+* char 2
+* ...
+* char n + $80 symbol termination flag (char set < 128 code points)
+* LFA (link field address):
+* link high byte \___pointer to previous word in list
+* link low byte / -- Combined allocation/dictionary list. --
+* CFA (code field address):
+* CFA high byte \___pointer to native CPU machine code
+* CFA low byte / -- Consider this the characteristic code. --
+* PFA (parameter field address):
+* parameter fields -- Machine code for low-level native machine CPU code,
+* " instruction list for high-level Forth code,
+* " constant data for constants, pointers to per task variables,
+* " space for variables, for global variables, etc.
+*
+* In the case of native CPU machine code, the address at CFA will be PFA.
+
+* Definition attributes:
+FIMMED EQU $40 ; Immediate word flag.
+FSMUDG EQU $20 ; Smudged => definition not ready.
+CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte.
+* Note that the SMUDGE bit is not masked out.
+*
+* But we really want more (Thinking for a new model, need one more byte):
+* FCOMPI EQU $10 ; Compile-time-only.
+* FASSEM EQU $08 ; Assembly-language code only.
+* F4THLV EQU $04 ; Must not be called from assembly language code.
+* These would require some significant adjustments to the model.
+* We also want to put the low-level VM stuff in its own vocabulary.
+*
+* ======>> 11 <<
+* (FIND) ( name vocptr --- locptr length true )
+* ( name vocptr --- false )
+* Search vocabulary for a symbol called name.
+* name is a pointer to a high-bit bracket string with length head.
+* vocptr is a pointer to the NFA of the tail-end (LATEST) definition
+* in the vocabulary to be searched.
+* Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
+ FCB $86
+ FCC '(FIND' ; '(FIND)'
+ FCB $A9
+ FDB DIGIT-8
+PFIND FDB *+NATWID
+ PSHS Y ; Have to track two pointers.
+* Use the stack and registers instead of temp area N.
+PA0 EQU NATWID ; pointer to the length byte of name being searched against
+PD EQU 0 ; pointer to NFA of dict word being checked
+*
+* INC <TRACEM
+* LBSR DBGREG
+ LDX PD,U ; Start in on the vocabulary (NFA).
+PFNDLP LDY PA0,U ; Point to the name to check against.
+ LDB ,X+ ; get dict name length byte
+ TFR B,A ; Save it in case it matches.
+ ANDB #CTMASK
+* LBSR DBGREG
+ CMPB ,Y+ ; Compare lengths
+* LBSR DBGREG
+ BNE PFNDUN
+PFNDBR LDB ,X+
+ TSTB ; ; Is high bit of character in dictionary entry set?
+* LBSR DBGREG
+ BPL PFNDCH
+* LBSR DBGREG
+ ANDB #$7F ; Clear high bit from dictionary.
+ CMPB ,Y+ ; Compare "last" characters.
+* LBSR DBGREG
+ BEQ FOUND ; Matches even if dictionary actual length is shorter.
+PFNDLN LDX ,X++ ; Get previous link in vocabulary.
+* LBSR DBGREG
+ BNE PFNDLP ; Continue if link not=0
+*
+* not found :
+ LEAU NATWID,U ; Return only false flag.
+ LDD #0
+ STD ,U
+* LBSR DBGREG
+* DEC <TRACEM
+ PULS Y,PC
+*
+PFNDCH CMPB ,Y+ ; Compare characters.
+* LBSR DBGREG
+ BEQ PFNDBR
+PFNDUN
+PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
+* LBSR DBGREG
+ BPL PFNDSC
+* LBSR DBGREG
+ BRA PFNDLN
+*
+* found :
+*
+FOUND LEAX 2*NATWID,X
+* LBSR DBGREG
+ STX NATWID,U
+ TFR A,B
+ CLRA
+ STD ,U
+* LBSR DBGREG
+ LDB #1
+ PSHU A,B
+* LBSR DBGREG
+* DEC <TRACEM
+ PULS Y,PC
+*
+* 6800 model:
+* NOP ; Probably leftovers from a debugging session.
+* NOP
+* PD EQU N ptr to dict word being checked
+* PA0 EQU N+2
+* PA EQU N+4
+* PC EQU N+6
+* LDX #PD
+* LDB #4
+* PFIND0 PULS A ; loop to get arguments
+* STA 0,X
+* LEAX 1,X ;
+* DECB ;
+* BNE PFIND0
+*
+* LDX PD
+* PFNDLP LDB 0,X get count dict count
+* STB PC
+* ANDB #$3F
+* LEAX 1,X ;
+* STX PD update PD
+* LDX PA0
+* LDA 0,X get count from arg
+* LEAX 1,X ;
+* STX PA intialize PA
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ; compare lengths
+* BNE PFNDUN
+* PFNDBR LDX PA
+* LDA 0,X
+* LEAX 1,X ;
+* STX PA
+* LDX PD
+* LDB 0,X
+* LEAX 1,X ;
+* STX PD
+* TSTB ; is dict entry neg. ?
+* BPL PFNDCH
+* ANDB #$7F clear sign
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ;
+* BEQ FOUND
+* PFNDLN LDX 0,X get new link
+* BNE PFNDLP continue if link not=0
+*
+* not found :
+*
+* CLRA ;
+* CLRB ;
+* JMP PUSHBA
+* PFNDCH PSHS B ; ** emulating CBA:
+* CMPA ,S+ ;
+* BEQ PFNDBR
+* PFNDUN LDX PD
+* PFNDSC LDB 0,X scan forward to end of this name
+* LEAX 1,X ;
+* BPL PFNDSC
+* BRA PFNDLN
+*
+* found :
+*
+* FOUND LDA PD compute CFA
+* LDB PD+1
+* ADDB #4
+* ADCA #0
+* PSHS B ;
+* PSHS A ;
+* LDA PC
+* PSHS A ;
+* CLRA ;
+* PSHS A ;
+* LDB #1
+* JMP PUSHBA
+*
+* PSHS A ; Left over from a stray copy-paste, I guess.
+* CLRA ;
+* PSHS A ;
+* LDB #1
+* JMP PUSHBA
+*
+* ######>> screen 20 <<
+* ======>> 12 <<
+* ( buffer ch --- buffer symboloffset delimiteroffset scancount )
+* ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
+* ( buffer ch --- buffer nuloffset onepast scancount )
+* Scan buffer for a symbol delimited by ch or ASCII NUL,
+* return the length of the buffer region scanned,
+* the offset to the trailing delimiter,
+* and the offset of the first character of the symbol.
+* Leave the buffer on the stack.
+* Scancount is also offset to first character not yet looked at.
+* If no symbol in buffer, scancount and symboloffset point to NUL
+* and delimiteroffset points one beyond for some reason.
+* On trailing NUL, delimiteroffset == scancount.
+* (Buffer is the address of the buffer array to scan.)
+* (This is a bit too tricky, really.)
+ FCB $87
+ FCC 'ENCLOS' ; 'ENCLOSE'
+ FCB $C5
+ FDB PFIND-9
+ENCLOS FDB *+NATWID
+ LDA 1,U ; Delimiter character to match against in A.
+ LDX NATWID,U ; Buffer to scan in.
+ CLRB ; Initialize offset. (Buffer < 256 wide!)
+* Scan to a non-delimiter or a NUL
+ENCDEL TST B,X ; NUL ?
+ BEQ ENCNUL
+ CMPA B,X ; Delimiter?
+ BNE ENC1ST
+ INCB ; count character
+ BRA ENCDEL
+* Found first character. Save the offset.
+ENC1ST STB 1,U ; Found first non-delimiter character --
+ CLR ,U ; store the count, zero high byte.
+* Scan to a delimiter or a NUL
+ENCSYM TST B,X ; NUL ?
+ BEQ ENC0TR
+ CMPA B,X ; delimiter?
+ BEQ ENCEND
+ INCB
+ BRA ENCSYM
+* Found end of symbol. Push offset to delimiter found.
+ENCEND CLRA ; high byte -- buffer < 255 wide!
+ PSHU A,B ; Offset to seen delimiter.
+* Advance and push address of next character to check.
+ ADDD #1 ; In case offset was 255.
+ PSHU A,B
+ RTS
+* Found NUL before non-delimiter, therefore there is no word
+ENCNUL CLRA ; high byte -- buffer < 255 wide!
+ STD ,U ; offset to NUL.
+ ADDD #1 ; Point after NUL to allow (FIND) to match it.
+ PSHU A,B ;
+ SUBD #1 ; Next is not passed NUL.
+ PSHU A,B ; Stealing code will save only one byte.
+ RTS
+* Found NUL following the word instead of delimiter.
+ENC0TR
+* INC <TRACEM
+* LBSR DBGREG
+ CLRA
+ PSHU A,B ; Save offset to first after symbol (NUL)
+* LBSR DBGREG
+ PSHU A,B ; and count scanned.
+* LBSR DBGREG
+* DEC <TRACEM
+ RTS
+* NOTE :
+* FC means offset (bytes) to First Character of next word
+* EW " " to End of Word
+* NC " " to Next Character to start next enclose at
+* ENCLOS FDB *+NATWID
+* LEAS 1,S ;
+* PULS B ; now, get the low byte, for an 8-bit delimiter
+* TFR S,X ; TSX :
+* LDX 0,X
+* CLR N
+* * wait for a non-delimiter or a NUL
+* ENCDEL LDA 0,X
+* BEQ ENCNUL
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ; CHECK FOR DELIM
+* BNE ENC1ST
+* LEAX 1,X ;
+* INC N
+* BRA ENCDEL
+* * found first character. Push FC
+* ENC1ST LDA N found first char.
+* PSHS A ;
+* CLRA ;
+* PSHS A ;
+* wait for a delimiter or a NUL
+* ENCSYM LDA 0,X
+* BEQ ENC0TR
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ; ckech for delim.
+* BEQ ENCEND
+* LEAX 1,X ;
+* INC N
+* BRA ENCSYM
+* * found EW. Push it
+* ENCEND LDB N
+* CLRA ;
+* PSHS B ;
+* PSHS A ;
+* * advance and push NC
+* INCB ;
+* JMP PUSHBA
+* found NUL before non-delimiter, therefore there is no word
+* ENCNUL LDB N found NUL
+* PSHS B ;
+* PSHS A ;
+* INCB ;
+* BRA ENC0TR+2 ; ********** POTENTIAL BUG HERE *******
+* ******** Should use labels in case opcodes change! ********
+* found NUL following the word instead of SPACE
+* ENC0TR LDB N
+* PSHS B ; save EW
+* PSHS A ;
+* ENCL8 LDB N save NC
+* JMP PUSHBA
+
+ PAGE
+*
+* ######>> screen 21 <<
+* The next 4 words call system dependant I/O routines
+* which are listed after word "-->" ( lable: "arrow" )
+* in the dictionary.
+*
+* ======>> 13 <<
+* ( c --- )
+* Write c to the output device (screen or printer).
+* ROM Uses the ECB device number at address $6F,
+* -2 is printer, 0 is screen.
+ FCB $84
+ FCC 'EMI' ; 'EMIT'
+ FCB $D4
+ FDB ENCLOS-10
+EMIT FDB *+NATWID
+ PULU D
+ LBSR PEMIT ; PEMIT expects the character in D.
+ INC <XOUT+1
+ BNE EMITDN
+ INC <XOUT
+EMITDN RTS
+* PULS A ;
+* PULS A ;
+* JSR PEMIT
+* LDX UP
+* INC XOUT+1-UORIG,X
+* BNE *+4 ;
+* ****WARNING**** HARD OFFSET: *+4 ****
+* INC XOUT-UORIG,X
+* JMP NEXT
+*
+* ======>> 14 <<
+* ( --- c )
+* ( --- BREAK )
+* Wait for a key from the keyboard.
+* If the key is BREAK, set the high byte (result $FF03).
+ FCB $83
+ FCC 'KE' ; 'KEY'
+ FCB $D9
+ FDB EMIT-7
+KEY FDB *+NATWID
+ LBSR PKEY ; PKEY leaves the key/break code in D.
+ PSHU D
+ RTS
+* JSR PKEY
+* PSHS A ;
+* CLRA ;
+* PSHS A ;
+* JMP NEXT
+*
+* ======>> 15 <<
+* ( --- f )
+* Scan keyboard, but do not wait.
+* Return 0 if no key,
+* BREAK ($ff03) if BREAK is pressed,
+* or key currently pressed.
+ FCB $89
+ FCC '?TERMINA' ; '?TERMINAL'
+ FCB $CC
+ FDB KEY-6
+QTERM FDB *+NATWID
+ LBSR PQTER ; PQTER leaves the flag/key in D.
+ PSHU D
+ RTS
+* JSR PQTER
+* CLRB ;
+* JMP PUSHBA stack the flag
+*
+* ======>> 16 <<
+* ( --- )
+* EMIT a Carriage Return (ASCII CR).
+ FCB $82
+ FCC 'C' ; 'CR'
+ FCB $D2
+ FDB QTERM-12
+CR FDB *+NATWID
+ LBRA PCR ; Nothing really to do here.
+* JSR PCR
+* JMP NEXT
+*
+* ######>> screen 22 <<
+* ======>> 17 <<
+* ( source target count --- )
+* Copy/move count bytes from source to target.
+* Moves ascending addresses,
+* so that overlapping only works if the source is above the destination.
+ FCB $85
+ FCC 'CMOV' ; 'CMOVE' : source, destination, count
+ FCB $C5
+ FDB CR-5
+CMOVE FDB *+NATWID
+* Another way ; takes ( 42+17*count+9*(count/256) cycles )
+ LDD #0 ; #3~3
+ SUBD ,U++ ; #2~9 ; invert the count
+ PSHS A,Y ; #2~8
+ PULU X,Y ; #2~9
+ BEQ CMOVEX ; #2~3
+CMOVEL
+ LDA ,Y+ ; #2~6
+ STA ,X+ ; #2~6
+ INCB ; #1~2
+ BNE CMOVEL ; #2~3
+ INC ,S ; #2~6
+ BNE CMOVEL ; #2~3
+CMOVEX PULS A,Y,PC ; #2~10
+* PSHS Y ;
+* INC <TRACEM
+* LBSR DBGREG
+* LDX 1*NATWID,U
+* LDY 2*NATWID,U
+* BRA CMOVLE ;
+* CMOVLP
+* LBSR DBGREG
+* LDA ,Y+
+* STA ,X+
+* LBSR DBGREG
+* CMOVLE
+* LDD ,U
+* SUBD #1
+* STD ,U
+* BCC CMOVLP
+* LEAU 3*NATWID,U
+* DEC <TRACEM
+* PULS Y,PC
+* One way: ; takes ( 37+17*count+9*(count/256) cycles )
+* PSHS Y ; #2~7 ; Gotta have our pointers.
+* INC <TRACEM
+* LBSR DBGREG
+* PULU D,X,Y ; #2~11
+* PSHS A ; #2~6 ; Gotta have our pointers.
+* BRA CMOVLE ; #2~3
+* CMOVLP
+* LBSR DBGREG
+* LDA ,Y+ ; #2~6
+* STA ,X+ ; #2~6
+* LBSR DBGREG
+* CMOVLE
+* SUBB #1 ; #2~2
+* BCC CMOVLP ; #2~3
+* DEC ,S ; #2=6
+* BPL CMOVLP ; #2~3 ; If this actually works, it is limited to 32k here.
+* DEC <TRACEM
+* PULS A,Y,PC ; #2~10
+* Yet another way ; takes ( 37+29*count cycles )
+* PSHS Y ; #2~7
+* LDX NATWID,U ; #2~6
+* LDY NATWID,U ; #3~7
+* BRA CMOVLE ; #2~3
+* CMOVLP
+* LDA ,Y+ ; #2~6
+* STA ,X+ ; #2~6
+* CMOVLE
+* LDD ,U ; #2~5
+* SUBD #1 ; #3~4
+* STD ,U ; #2~5
+* BPL CMOVLP ; #2~3
+* LEAU 3*NATWID,U ; #2~5
+* PULS Y,PC ; #2~9
+* Yet another way ; takes ( 44+24*odd+33*count/2 cycles )
+* PSHS Y ; #2~7
+* LDX NATWID,U ; #2~6
+* LDY 2*NATWID,U ; #3~7
+* LDD ,U ; #2~5
+* BITB #1 ; #2~2
+* BEQ CMOVLE ; #2~3
+* SUBD #1 ; #3~4
+* STD ,U ; #2~5
+* LDA ,Y+ ; #2~6
+* STA ,X+ ; #2~6
+* BRA CMOVLE ; #2~3
+* CMOVLP
+* LDD ,Y++ ; #2~8
+* STD ,X++ ; #2~8
+* CMOVLI
+* LDD ,U ; #2~5
+* CMOVLE
+* SUBD #2 ; #3~4
+* STD ,U ; #2~5
+* BPL CMOVLP ; #2~3
+* LEAU 3*NATWID,U ; #2~5
+* PULS Y,PC ; #2~9
+* From the 6800 model:
+* CMOVE FDB *+2 takes ( 43+47*count cycles ) on 6800
+* LDX #N
+* LDB #6
+* CMOV1 PULS A ;
+* STA 0,X move parameters to scratch area
+* LEAX 1,X ;
+* DECB ;
+* BNE CMOV1
+* CMOV2 LDA N
+* LDB N+1
+* SUBB #1
+* SBCA #0
+* STA N
+* STB N+1
+* BCS CMOV3
+* LDX N+4
+* LDA 0,X
+* LEAX 1,X ;
+* STX N+4
+* LDX N+2
+* STA 0,X
+* LEAX 1,X ;
+* STX N+2
+* BRA CMOV2
+* CMOV3 JMP NEXT
+*
+* ######>> screen 23 <<
+* ======>> 18 <<
+* ( u1 u2 --- ud )
+* Multiplies the top two unsigned integers,
+* yielding a double integer product.
+ FCB $82
+ FCC 'U' ; 'U*'
+ FCB $AA
+ FDB CMOVE-8
+USTAR FDB *+NATWID
+ LEAU -2*NATWID,U
+ LDA 2*NATWID+1,U ; least
+ LDB 3*NATWID+1,U
+ MUL
+ STD NATWID,U
+ LDA 2*NATWID,U ; most
+ LDB 3*NATWID,U
+ MUL
+ STD ,U
+ LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi)
+ MUL
+ ADDD 1,U
+ BCC USTAR3
+ INC ,U
+USTAR3 STD 1,U
+ LDA 2*NATWID,U ; second inner (u2 hi)
+ LDB 3*NATWID,U ; (u1 lo)
+ MUL
+ ADDD 1,U
+ BCC USTAR4
+ INC ,U
+USTAR4 STD 1,U
+ PULU D,X
+ STD ,U
+ STX NATWID,U
+ RTS
+*
+* from 6800 model:
+* BSR USTARS
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP PUSHBA
+*
+* The following is a subroutine which
+* multiplies top 2 words on stack,
+* leaving 32-bit result: high order word in A,B
+* low order word in 2nd word of stack.
+*
+* USTARS LDA #16 bits/word counter
+* PSHS A ;
+* CLRA ;
+* CLRB ;
+* TFR S,X ; TSX :
+* USTAR2 ROR 5,X shift multiplier
+* ROR 6,X
+* DEC 0,X done?
+* BMI USTAR4
+* BCC USTAR3
+* ADDB 4,X
+* ADCA 3,X
+* USTAR3 RORA ;
+* RORB ; shift result
+* BRA USTAR2
+* USTAR4 LEAS 1,S ; dump counter
+* RTS
+*
+* ######>> screen 24 <<
+* ======>> 19 <<
+* ( ud u --- uremainder uquotient )
+* Divides the top unsigned integer
+* into the second and third words on the stack
+* as a single unsigned double integer,
+* leaving the remainder and quotient (quotient on top)
+* as unsigned integers.
+*
+* The smaller the divisor, the more likely dropping the high word
+* of the quotient loses significant bits. See M/MOD .
+*
+ FCB $82
+ FCC 'U' ; 'U/'
+ FCB $AF
+ FDB USTAR-5
+USLASH FDB *+NATWID
+ LDA #17 ; bit ct
+ PSHS A
+ LDD NATWID,U ; dividend
+USLDIV CMPD ,U ; divisor
+ BHS USLSUB
+ ANDCC #~1 ; carry clear
+ BRA USLBIT
+USLSUB SUBD ,U
+ ORCC #1 ; quotient, (carry set)
+USLBIT ROL 2*NATWID+1,U ; save it
+ ROL 2*NATWID,U
+ DEC ,S ; more bits?
+ BEQ USLR
+ ROLB ; remainder
+ ROLA
+ BCC USLDIV
+ BRA USLSUB
+USLR LEAU NATWID,U
+ LDX NATWID,U
+ STD NATWID,U
+ STX ,U
+ PULS A,PC ; Avoiding a LEAS 1,S by discarding A.
+*
+* from 6800 model:
+* LDA #17
+* PSHS A ;
+* TFR S,X ; TSX :
+* LDA 3,X
+* LDB 4,X
+* USL1 CMPA 1,X
+* BHI USL3
+* BCS USL2
+* CMPB 2,X
+* BCC USL3
+* USL2 ANDCC #~$01 ; CLC :
+* BRA USL4
+* USL3 SUBB 2,X
+* SBCA 1,X
+* ORCC #$01 ; SEC :
+* USL4 ROL 6,X
+* ROL 5,X
+* DEC 0,X
+* BEQ USL5
+* ROLB ;
+* ROLA ;
+* BCC USL1
+* BRA USL3
+* USL5 LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP SWAP+4 reverse quotient & remainder
+*
+* ######>> screen 25 <<
+* ======>> 20 <<
+* ( n1 n2 --- n )
+* Bitwise and the top two integers.
+ FCB $83
+ FCC 'AN' ; 'AND'
+ FCB $C4
+ FDB USLASH-5
+AND FDB *+NATWID
+ PULU A,B
+ ANDB 1,U
+ ANDA ,U
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* ANDB 1,X
+* ANDA 0,X
+* JMP STABX
+*
+* ======>> 21 <<
+* ( n1 n2 --- n )
+* Bitwise or the top two integers.
+ FCB $82
+ FCC 'O' ; 'OR'
+ FCB $D2
+ FDB AND-6
+OR FDB *+NATWID
+ PULU A,B
+ ORB 1,U
+ ORA ,U
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* ORB 1,X
+* ORA 0,X
+* JMP STABX
+*
+* ======>> 22 <<
+* ( n1 n2 --- n )
+* Bitwise exclusive or the top two integers.
+ FCB $83
+ FCC 'XO' ; 'XOR'
+ FCB $D2
+ FDB OR-5
+XOR FDB *+NATWID
+ PULU A,B
+ EORB 1,U
+ EORA ,U
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* EORB 1,X
+* EORA 0,X
+* JMP STABX
+*
+* ######>> screen 26 <<
+* ======>> 23 <<
+* ( --- adr )
+* Fetch the parameter stack pointer (before it is pushed).
+* This points at whatever was on the top of stack before.
+ FCB $83
+ FCC 'SP' ; 'SP@'
+ FCB $C0
+ FDB XOR-6
+SPAT FDB *+NATWID
+ TFR U,X
+ PSHU X
+ RTS
+* TFR S,X ; TSX :
+* STX N scratch area
+* LDX #N
+* JMP GETX
+*
+* ======>> 24 <<
+* ( whatever --- nothing )
+* Initialize the parameter stack pointer from the USER variable S0.
+* Effectively clears the stack.
+ FCB $83
+ FCC 'SP' ; 'SP!'
+ FCB $A1
+ FDB SPAT-6
+SPSTOR FDB *+NATWID
+ LDU <XSPZER
+ RTS
+* LDX UP
+* LDX XSPZER-UORIG,X
+* TFR X,S ; TXS : watch it ! X and S are not equal on 6800.
+* JMP NEXT
+* ======>> 25 <<
+* ( whatever *** nothing )
+* Initialize the return stack pointer from the initialization table
+* instead of the user variable R0, for some reason.
+* Quite possibly, this should be from R0.
+* Effectively aborts all in process definitions, except the active one.
+* An emergency measure, to be sure.
+* The routine that calls this must never execute a return.
+* So this should never be executed from the terminal, I guess.
+* This is another that should be compile-time only, and in a separate vocabulary.
+ FCB $83
+ FCC 'RP' ; 'RP!'
+ FCB $A1
+ FDB SPSTOR-6
+RPSTOR FDB *+NATWID
+ PULS X ; But this guy has to return to his caller.
+ LDS RINIT
+ JMP ,X
+* LDX RINIT initialize from rom constant
+* STX RP
+* JMP NEXT
+*
+* ======>> 26 <<
+* ( ip *** )
+* Pop IP from return stack (return from high-level definition).
+* Can be used in a screen to force interpretion to terminate.
+* Must not be executed when temporaries are saved on top of the return stack.
+ FCB $82
+ FCC ';' ; ';S'
+ FCB $D3
+ FDB RPSTOR-6
+SEMIS FDB *+NATWID
+ PULS D,Y ; return address in D, and saved IP in Y.
+ TFR D,PC ; Synthetic return.
+*
+* Form 6800 model:
+* LDX RP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX RP
+* LDX 0,X get address we have just finished.
+* JMP NEXT+2 increment the return address & do next word
+*
+* ######>> screen 27 <<
+* ======>> 27 <<
+* ( limit index *** index index )
+* Force the terminating condition for the innermost loop by
+* copying its index to its limit.
+* Termination is postponed until the next
+* LOOP or +LOOP instruction is executed.
+* The index remains available for use until
+* the LOOP or +LOOP instruction is encountered.
+* Note that the assumption is that the current count is the correct count
+* to end at, rather than pushing the count to the final count.
+ FCB $85
+ FCC 'LEAV' ; 'LEAVE'
+ FCB $C5
+ FDB SEMIS-5
+LEAVE FDB *+NATWID
+ LDD NATWID,S ; Dodge the return address.
+ STD 2*NATWID,S
+ RTS
+* LDX RP
+* LDA 2,X
+* LDB 3,X
+* STA 4,X
+* STB 5,X
+* JMP NEXT
+*
+* ======>> 28 <<
+* ( n --- )
+* ( *** n )
+* Move top of parameter stack to top of return stack.
+ FCB $82
+ FCC '>' ; '>R'
+ FCB $D2
+ FDB LEAVE-8
+TOR FDB *+NATWID
+ PULU A,B
+ LDX ,S
+ STD ,S ; Put it where the return address was.
+ JMP ,X
+* LDX RP
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* PULS A ;
+* PULS B ;
+* STA 2,X
+* STB 3,X
+* JMP NEXT
+*
+* ======>> 29 <<
+* ( --- n )
+* ( n *** )
+* Move top of return stack to top of parameter stack.
+ FCB $82
+ FCC 'R' ; 'R>'
+ FCB $BE
+ FDB TOR-5
+FROMR FDB *+NATWID
+ PULS D,X
+ PSHU X
+ TFR D,PC
+* LDX RP
+* LDA 2,X
+* LDB 3,X
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX RP
+* JMP PUSHBA
+*
+* ======>> 30 <<
+* ( --- n )
+* ( n *** n )
+* Copy the top of return stack to top of parameter stack.
+* A synonym for I.
+ FCB $81 R
+ FCB $D2
+ FDB FROMR-5
+R FDB I+NATWID
+
+* LDX RP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* JMP GETX
+*
+* ######>> screen 28 <<
+* ======>> 31 <<
+* ( n --- ~n )
+* Logically invert top of stack;
+* or flag true if top is zero, otherwise false.
+ FCB $83
+ FCC 'NO' ; 'NOT'
+ FCB $D4
+ FDB R-4
+LNOT FDB *+NATWID
+ COM 1,U
+ COM ,U
+ RTS
+* ( n --- n=0 )
+* Logically invert top of stack;
+* or flag true if top is zero, otherwise false.
+ FCB $82
+ FCC '0' ; '0='
+ FCB $BD
+ FDB LNOT-6
+ZEQU FDB *+NATWID
+ LDD #0
+ LDX ,U
+ BNE ZEQUF
+ INCB ; 1 is true
+ZEQUF STD ,U
+ RTS
+* TFR S,X ; TSX :
+* CLRA ;
+* CLRB ;
+* LDX 0,X
+* BNE ZEQU2
+* INCB ;
+*ZEQU2 TFR S,X ; TSX :
+* JMP STABX
+*
+* ======>> 32 <<
+* ( n --- n<0 )
+* Flag true if top is negative (MSbit set), otherwise false.
+ FCB $82
+ FCC '0' ; '0<'
+ FCB $BC
+ FDB ZEQU-5
+ZLESS FDB *+NATWID
+ LDD #0
+ TST ,U
+ BPL ZLESSF
+ INCB
+ZLESSF STD ,U
+ RTS
+* TFR S,X ; TSX :
+* LDA #$80 check the sign bit
+* ANDA 0,X
+* BEQ ZLESS2
+* CLRA ; if neg.
+* LDB #1
+* JMP STABX
+* ZLESS2 CLRB ;
+* JMP STABX
+*
+* ######>> screen 29 <<
+* ======>> 33 <<
+* ( n1 n2 --- n1+n2 )
+* Add top two words.
+ FCB $81 '+'
+ FCB $AB
+ FDB ZLESS-5
+PLUS FDB *+NATWID
+ PULU A,B ; #2~7
+ ADDD ,U ; #2~6
+ STD ,U ; #2~5
+ RTS ; #1~5 =#7~23
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* ADDB 1,X
+* ADCA 0,X
+* JMP STABX
+*
+* ======>> 34 <<
+* ( d1 d2 --- d1+d2 )
+* Add top two double integers.
+ FCB $82
+ FCC 'D' ; 'D+'
+ FCB $AB
+ FDB PLUS-4
+DPLUS FDB *+NATWID
+ LDD 3*NATWID,U
+ ADDD NATWID,U
+ STD 3*NATWID,U
+ LDD 2*NATWID,U
+ ADCB 1,U
+ ADCA ,U
+ LEAU 2*NATWID,U
+ STD ,U
+ RTS
+* TFR S,X ; TSX :
+* ANDCC #~$01 ; CLC :
+* LDB #4
+* DPLUS2 LDA 3,X
+* ADCA 7,X
+* STA 7,X
+* LEAX -1,X ;
+* DECB ;
+* BNE DPLUS2
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP NEXT
+*
+* ======>> 35 <<
+* ( n --- -n )
+* Negate (two's complement) top of stack.
+ FCB $85
+ FCC 'MINU' ; 'MINUS'
+ FCB $D3
+ FDB DPLUS-5
+MINUS FDB *+NATWID
+ LDD #0 ; #3~3
+ SUBD ,U ; #2~5
+ STD ,U ; #2~5
+ RTS ; #1~5 = #8~18
+*
+* from 6800 model code:
+* TFR S,X ; TSX :
+* NEG 1,X
+* BCC MINUS2
+* NEG 0,X
+* BRA MINUS3
+* MINUS2 COM 0,X
+* MINUS3 JMP NEXT
+*
+* ======>> 36 <<
+* ( d --- -d )
+* Negate (two's complement) top two words on stack as a double integer.
+ FCB $86
+ FCC 'DMINU' ; 'DMINUS'
+ FCB $D3
+ FDB MINUS-8
+DMINUS FDB *+NATWID
+ LDD #0 ; #3~3
+ SUBD NATWID,U ; #2~7
+ STD NATWID,U ; #2~7
+ LDD #0 ; #3~3
+ SBCB 1,U ; #2~5
+ SBCA ,U ; #2~4
+ STD ,U ; #2~5
+ RTS ; #1~5 = #17~39
+* TFR S,X ; TSX :
+* COM 0,X
+* COM 1,X
+* COM 2,X
+* NEG 3,X
+* BNE DMINX
+* INC 2,X
+* BNE DMINX
+* INC 1,X
+* BNE DMINX
+* INC 0,X
+* DMINX JMP NEXT
+*
+* ######>> screen 30 <<
+* ======>> 37 <<
+* ( n1 n2 --- n1 n2 n1 )
+* Push a copy of the second word on stack.
+ FCB $84
+ FCC 'OVE' ; 'OVER'
+ FCB $D2
+ FDB DMINUS-9
+OVER FDB *+NATWID
+ LDD NATWID,U
+ PSHU D
+ RTS
+* TFR S,X ; TSX :
+* LDA 2,X
+* LDB 3,X
+* JMP PUSHBA
+*
+* ======>> 38 <<
+* ( n --- )
+* Discard the top word on stack.
+ FCB $84
+ FCC 'DRO' ; 'DROP'
+ FCB $D0
+ FDB OVER-7
+DROP FDB *+NATWID
+ LEAU NATWID,U
+ RTS
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP NEXT
+*
+* ======>> 39 <<
+* ( n1 n2 --- n2 n1 )
+* Swap the top two words on stack.
+ FCB $84
+ FCC 'SWA' ; 'SWAP'
+ FCB $D0
+ FDB DROP-7
+SWAP FDB *+NATWID
+ PULU D,X
+ PSHU D
+ PSHU X
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* LDX 0,X
+* LEAS 1,S ;
+* LEAS 1,S ;
+* PSHS B ;
+* PSHS A ;
+* STX N
+* LDX #N
+* JMP GETX
+*
+* ======>> 40 <<
+* ( n1 --- n1 n1 )
+* Push a copy of the top word on stack.
+ FCB $83
+ FCC 'DU' ; 'DUP'
+ FCB $D0
+ FDB SWAP-7
+DUP FDB *+NATWID
+ LDD ,U
+ PSHU D
+ RTS
+* PULS A ;
+* PULS B ;
+* PSHS B ;
+* PSHS A ;
+* JMP PUSHBA
+*
+* ######>> screen 31 <<
+* ======>> 41 <<
+* ( n adr --- )
+* Add the second word on stack to the word at the adr on top of stack.
+ FCB $82
+ FCC '+' ; '+!'
+ FCB $A1
+ FDB DUP-6
+PSTORE FDB *+NATWID
+ PULU X
+ LDD ,X
+ ADDD ,U++
+ STD ,X
+ RTS
+* TFR S,X ; TSX :
+* LDX 0,X
+* LEAS 1,S ;
+* LEAS 1,S ;
+* PULS A ; get stack data
+* PULS B ;
+* ADDB 1,X add & store low byte
+* STB 1,X
+* ADCA 0,X add & store hi byte
+* STA 0,X
+* JMP NEXT
+*
+* ======>> 42 <<
+* ( adr b --- )
+* Exclusive or byte at adr with low byte of top word.
+ FCB $86
+ FCC 'TOGGL' ; 'TOGGLE'
+ FCB $C5
+ FDB PSTORE-5
+TOGGLE FDB *+NATWID
+ PULU D,X
+ EORB ,X
+ STB ,X
+ RTS
+* Using the model code would be less likely to introduce bugs,
+* but that would sort-of defeat my purposes here.
+* Anyway, I can borrow from theoretically known good bif-6809 code
+* and it's fewer bytes and much faster code this way.
+* TOGGLE
+* FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
+* FDB SEMIS
+*
+* ######>> screen 32 <<
+* ======>> 43 <<
+* ( adr --- n )
+* Replace address on stack with the word at the address.
+ FCB $81 @
+ FCB $C0
+ FDB TOGGLE-9
+AT FDB *+NATWID
+ LDD [,U]
+ STD ,U
+ RTS
+* TFR S,X ; TSX :
+* LDX 0,X get address
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP GETX
+*
+* ======>> 44 <<
+* ( adr --- b )
+* Replace address on top of stack with the byte at the address.
+* High byte of result is clear.
+ FCB $82
+ FCC 'C' ; 'C@'
+ FCB $C0
+ FDB AT-4
+CAT FDB *+NATWID
+ LDB [,U]
+ CLRA
+ STD ,U
+ RTS
+
+
+* TFR S,X ; TSX :
+* LDX 0,X
+* CLRA ;
+* LDB 0,X
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP PUSHBA
+*
+* ======>> 45 <<
+* ( n adr --- )
+* Store second word on stack at address on top of stack.
+ FCB $81
+ FCB $A1
+ FDB CAT-5
+STORE FDB *+NATWID
+ LDD NATWID,U
+ STD [,U]
+ LEAU 2*NATWID,U
+ RTS
+* TFR S,X ; TSX :
+* LDX 0,X get address
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP PULABX
+*
+* ======>> 46 <<
+* ( b adr --- )
+* Store low byte of second word on stack at address on top of stack.
+* High byte is ignored.
+ FCB $82
+ FCC 'C' ; 'C!'
+ FCB $A1
+ FDB STORE-4
+CSTORE FDB *+NATWID
+ LDB 3,U
+ STB [,U]
+ LEAU 2*NATWID,U
+ RTS
+* TFR S,X ; TSX :
+* LDX 0,X get address
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* PULS B ;
+* STB 0,X
+* JMP NEXT
+ PAGE
+*
+* ######>> screen 33 <<
+* ======>> 47 <<
+* ( --- ) P
+* { : name sundry-activities ; } typical input
+* If executing (not compiling),
+* record the data stack mark in CSP,
+* Set the CONTEXT vocabulary to CURRENT,
+* CREATE a header,
+* set state to compile,
+* and compile the call to the trailing native CPU machine code DOCOL.
+*
+* This would not be hard to flatten to native code.
+* But that's not the purpose of a model.
+ FCB $C1 : immediate
+ FCB $BA
+ FDB CSTORE-5
+COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
+ FDB CREATE,RBRAK
+ FDB PSCODE
+
+* Here is the IP pusher for allowing
+* nested words in the virtual machine:
+* ( ;S is the equivalent un-nester )
+
+* ( *** oldIP )
+* Characteristic of a colon (:) definition.
+* Begins execution of a high-level definition,
+* i. e., nests the definition and begins processing icodes.
+* Mechanically, it pushes the IP (Y register)
+* and loads the Parameter Field Address of the definition which
+* called it into the IP.
+DOCOL LDD ,S ; Save the return address.
+ STY ,S ; Nest the old IP.
+ LEAY NATWID,X ; W still in X, bump to parameters, load as new IP.
+ TFR D,PC ; synthetic return to interpret.
+
+* DOCOL LDX RP make room in the stack
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* LDA IP
+* LDB IP+1
+* STA 2,X Store address of the high level word
+* STB 3,X that we are starting to execute
+* LDX W Get first sub-word of that definition
+* JMP NEXT+2 and execute it
+*
+* ======>> 48 <<
+* ( --- ) P
+* { : name sundry-activities ; } typical input
+* ERROR check data stack against mark in CSP,
+* compile ;S,
+* unSMUDGE LATEST definition,
+* and set state to interpretation.
+ FCB $C1 ; imnediate code
+ FCB $BB
+ FDB COLON-4
+SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
+ FDB SEMIS
+*
+* ######>> screen 34 <<
+* ======>> 49 <<
+* ( n --- )
+* { value CONSTANT name } typical input
+* CREATE a header,
+* unSMUDGE it,
+* compile the constant value,
+* and compile the call to the trailing native CPU machine code DOCON.
+ FCB $88
+ FCC 'CONSTAN' ; 'CONSTANT'
+ FCB $D4
+ FDB SEMI-4
+CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
+* ( --- n )
+* Characteristic of a CONSTANT.
+* A CONSTANT simply loads its value from its parameter field
+* and pushes it on the stack.
+DOCON LDD NATWID,X ; Get the first natural width word of the parameter field.
+ PSHU D
+ RTS
+* DOCON LDX W
+* LDA 2,X
+* LDB 3,X A & B now contain the constant
+* JMP PUSHBA
+*
+* Not in model, needed for abstraction:
+* ( --- NATWID )
+* The byte width of objects on stack.
+ FCB $86
+ FCC 'NATWI' ; 'NATWID'
+ FCB $C4
+ FDB CON-11
+NATWC FDB DOCON
+NATWCV FDB NATWID
+*
+* Not in model, needed for abstraction:
+* Note that this is not defined as an INCREMENTER!
+* Coded to increment by the exact constant returned by NATWID
+* ( n --- n+NATWID )
+ FCB $84
+ FCC 'NAT' ; 'NAT+'
+ FCB $AB
+ FDB NATWC-9
+NATP FDB *+NATWID
+ LDD ,U
+ ADDD NATWCV,PCR ; Looking ahead, does not have to be PCRelative.
+ STD ,U
+ RTS
+* How this might have been done for 6800 model:
+* CLRA ; We know the natural width is less than 255, LOL.
+* LDAB NATWCV+1
+* TSX
+* ADDB 1,X
+* ADCA ,X
+* JMP STABX
+*
+* ======>> 50 <<
+* ( init --- )
+* { init VARIABLE name } typical input
+* Use CONSTANT to CREATE a header and compile the initial value, init,
+* then overwrite the characteristic to point to DOVAR.
+ FCB $88
+ FCC 'VARIABL' ; 'VARIABLE'
+ FCB $C5
+ FDB NATP-7
+VAR FDB DOCOL,CON,PSCODE
+* ( --- vadr )
+* Characteristic of a VARIABLE.
+* A VARIABLE pushes its PFA address on the stack.
+* The parameter field of a VARIABLE is the actual allocation of the variable,
+* so that pushing its address allows its contents to be @ed (fetched).
+* Ordinary arrays and strings that do not subscript themselves
+* may be allocated by defining a variable
+* and immediately ALLOTting the remaining needed space.
+* VARIABLES are global to all users,
+* and thus should be hidden in resource monitors, but aren't.
+DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters.
+ PSHU X
+ RTS
+* DOVAR LDA W
+* LDB W+1
+* ADDB #2
+* ADCA #0 A,B now contain the address of the variable
+* JMP PUSHBA
+*
+* ======>> 51 <<
+* ( ub --- )
+* { uboffset USER name } typical input
+* CREATE a header and compile the unsigned byte offset in the per-USER table,
+* then overwrite the header with a call to DOUSER.
+* The USER is entirely responsible for maintaining allocation!
+ FCB $84
+ FCC 'USE' ; 'USER'
+ FCB $D2
+ FDB VAR-11
+USER FDB DOCOL,CON,PSCODE
+* ( --- vadr )
+* Characteristic of a per-USER variable.
+* USER variables are similiar to VARIABLEs,
+* but are allocated (by hand!) in the per-user table.
+* A USER variable's parameter field contains its offset in the per-user table.
+DOUSER TFR DP,A ; Make a pointer to the direct page.
+ CLRB
+* See Alternative -- alternatives start from this point.
+ ADDD NATWID,X ; Add it to the offset to the per-user variable.
+ PSHU D
+ TFR D,X ; Cache the pointer in X for the caller.
+ RTS
+* Hey, the per-user table could actually be larger than 256 bytes!
+* But we knew that. It's just not as esthetic to calculate it this way.
+* Alternative A:
+* LDX NATWID,X ; Keep the offset
+* EXG D,X ; Prepare for EA
+* LEAX D,X
+* PSHU X
+* RTS
+* Alternative B:
+* PSHS Y ; Get Y free for calculations.
+* TFR D,Y ; Y points to the UP base
+* LDD NATWID,X ; Get the offset
+* LEAX D,Y ; Leave the pointer cached in X.
+* PSHU X
+* PULS Y,PC
+*
+* From the 6800 model:
+* DOUSER LDX W get offset into user's table
+* LDA 2,X
+* LDB 3,X
+* ADDB UP+1 add to users base address
+* ADCA UP
+* JMP PUSHBA push address of user's variable
+*
+* ######>> screen 35 <<
+* ======>> 52 <<
+* ( --- 0 )
+ FCB $81
+ FCB $B0 0
+ FDB USER-7
+ZERO FDB DOCON
+ FDB 0000
+*
+* ======>> 53 <<
+* ( --- 1 )
+ FCB $81
+ FCB $B1 1
+ FDB ZERO-4
+ONE FDB DOCON
+ONEV FDB 1
+*
+* ======>> 54 <<
+* ( --- 2 )
+ FCB $81
+ FCB $B2 2
+ FDB ONE-4
+TWO FDB DOCON
+TWOV FDB 2
+*
+* ======>> 55 <<
+* ( --- 3 )
+ FCB $81
+ FCB $B3 3
+ FDB TWO-4
+THREE FDB DOCON
+ FDB 3
+*
+* ======>> 56 <<
+* ( --- SP )
+* ASCII SPACE character
+ FCB $82
+ FCC 'B' ; 'BL'
+ FCB $CC
+ FDB THREE-4
+BL FDB DOCON ascii blank
+ FDB $20
+*
+* ======>> 57 <<
+* This really shouldn't be a CONSTANT.
+* ( --- adr )
+* The base of the disk buffer space.
+ FCB $85
+ FCC 'FIRS' ; 'FIRST'
+ FCB $D4
+ FDB BL-5
+FIRST FDB DOCON
+ FDB BUFBAS
+* FDB MEMEND-528 (132 * NBLK)
+*
+* ======>> 58 <<
+* This really shouldn't be a CONSTANT.
+* ( --- adr )
+* The limit of the disk buffer space.
+ FCB $85
+ FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
+ FCB $D4
+ FDB FIRST-8
+LIMIT FDB DOCON
+ FDB BUFBAS+BUFSZ
+* In 6800 model, was
+* FDB MEMEND
+*
+* ======>> 59 <<
+* ( --- sectorsize )
+* The size, in bytes, of a buffer control region.
+ FCB $85
+ FCC 'B/CT' ; 'B/CTL' : (bytes/control region)
+ FCB $CC
+ FDB LIMIT-8
+BCTL FDB DOCON
+ FDB SECTRL
+*
+* ( --- sectorsize )
+* The size, in bytes, of a buffer.
+ FCB $85
+ FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
+ FCB $C6
+ FDB BCTL-8
+BBUF FDB DOCON
+ FDB SECTSZ
+* Hardcoded in 6800 model:
+* FDB 128
+*
+* ======>> 60 <<
+* ( --- blocksperscreen )
+* The size, in blocks, of a screen.
+* Should this be the same as NBLK, the number of block buffers maintained?
+ FCB $85
+ FCC 'B/SC' ; 'B/SCR' : (blocks/screen)
+ FCB $D2
+ FDB BBUF-8
+BSCR FDB DOCON
+ FDB SCRSZ/SECTSZ
+* Hardcoded in 6800 model as:
+* FDB 8
+* blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
+*
+* ======>> 61 <<
+* ( n --- adr )
+* Calculate the address of entry (#n/2) in the boot-up parameter table.
+* (Adds the base of the boot-up table to n.)
+ FCB $87
+ FCC '+ORIGI' ; '+ORIGIN'
+ FCB $CE
+ FDB BSCR-8
+PORIG FDB DOCOL,LIT,ORIG,PLUS
+ FDB SEMIS
+*
+* ######>> screen 36 <<
+* ======>> 62 <<
+* ( n --- adr )
+* This is the per-task variable recording the initial parameter stack pointer.
+ FCB $82
+ FCC 'S' ; 'S0'
+ FCB $B0
+ FDB PORIG-10
+SZERO FDB DOUSER
+ FDB XSPZER-UORIG
+*
+* ======>> 63 <<
+* ( n --- adr )
+* This is the per-task variable recording the initial return stack pointer.
+ FCB $82
+ FCC 'R' ; 'R0'
+ FCB $B0
+ FDB SZERO-5
+RZERO FDB DOUSER
+ FDB XRZERO-UORIG
+*
+* ======>> 64 <<
+* ( --- vadr )
+* Terminal Input Buffer address.
+* Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
+ FCB $83
+ FCC 'TI' ; 'TIB'
+ FCB $C2
+ FDB RZERO-5
+TIB FDB DOUSER
+ FDB XTIB-UORIG
+*
+* ======>> 65 <<
+* ( --- maxnamewidth )
+* This is the maximum width to which symbol names will be recorded.
+ FCB $85
+ FCC 'WIDT' ; 'WIDTH'
+ FCB $C8
+ FDB TIB-6
+WIDTH FDB DOUSER
+ FDB XWIDTH-UORIG
+*
+* ======>> 66 <<
+* ( --- vadr )
+* Availability of error messages on disk.
+* Contains 1 if messages available,
+* 0 if not,
+* -1 if a disk error has occurred.
+ FCB $87
+ FCC 'WARNIN' ; 'WARNING'
+ FCB $C7
+ FDB WIDTH-8
+WARN FDB DOUSER
+ FDB XWARN-UORIG
+*
+* ======>> 67 <<
+* ( --- vadr )
+* Boundary for FORGET.
+ FCB $85
+ FCC 'FENC' ; 'FENCE'
+ FCB $C5
+ FDB WARN-10
+FENCE FDB DOUSER
+ FDB XFENCE-UORIG
+*
+* ======>> 68 <<
+* ( --- vadr )
+* Dictionary pointer, fetched by HERE.
+ FCB $82
+ FCC 'D' ; 'DP' : points to first free byte at end of dictionary
+ FCB $D0
+ FDB FENCE-8
+DICTPT FDB DOUSER
+ FDB XDICTP-UORIG
+*
+* ======>> 68.5 <<
+* ( --- vadr ) ******* Need to check what this is!
+* Used in maintaining vocabularies.
+* I think it points to the "parent" vocabulary, but I'm not sure.
+* Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
+ FCB $88
+ FCC 'VOC-LIN' ; 'VOC-LINK'
+ FCB $CB
+ FDB DICTPT-5
+VOCLIN FDB DOUSER
+ FDB XVOCL-UORIG
+*
+* ======>> 69 <<
+* ( --- vadr )
+* Disk block being interpreted.
+* Zero refers to terminal.
+* ******** Should be made a 32 bit user variable! ********
+* But the base system needs to have full 32 bit support, div and mul, etc.
+* before we can do that.
+ FCB $83
+ FCC 'BL' ; 'BLK'
+ FCB $CB
+ FDB VOCLIN-11
+BLK FDB DOUSER
+ FDB XBLK-UORIG
+*
+* ======>> 70 <<
+* ( --- vadr )
+* Input buffer offset/cursor.
+ FCB $82
+ FCC 'I' ; 'IN' : scan pointer for input line buffer
+ FCB $CE
+ FDB BLK-6
+IN FDB DOUSER
+ FDB XIN-UORIG
+*
+* ======>> 71 <<
+* ( --- vadr )
+* Output buffer offset/cursor.
+ FCB $83
+ FCC 'OU' ; 'OUT'
+ FCB $D4
+ FDB IN-5
+OUT FDB DOUSER
+ FDB XOUT-UORIG
+*
+* ======>> 72 <<
+* ( --- vadr )
+* Screen currently being edited, once we have an editor running.
+ FCB $83
+ FCC 'SC' ; 'SCR'
+ FCB $D2
+ FDB OUT-6
+SCR FDB DOUSER
+ FDB XSCR-UORIG
+* ######>> screen 37 <<
+*
+* ======>> 73 <<
+* ( --- vadr )
+* Sector offset for LOADing screens,
+* set by DRIVE to make a new drive the default.
+* This should also be 32 bit or bigger.
+ FCB $86
+ FCC 'OFFSE' ; 'OFFSET'
+ FCB $D4
+ FDB SCR-6
+OFSET FDB DOUSER
+ FDB XOFSET-UORIG
+*
+* ======>> 74 <<
+* ( --- vadr )
+* Current context of interpretation (vocabulary root).
+ FCB $87
+ FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
+ FCB $D4
+ FDB OFSET-9
+CONTXT FDB DOUSER
+ FDB XCONT-UORIG
+*
+* ======>> 75 <<
+* ( --- vadr )
+* Current context of definition (vocabulary root).
+ FCB $87
+ FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
+ FCB $D4
+ FDB CONTXT-10
+CURENT FDB DOUSER
+ FDB XCURR-UORIG
+*
+* ======>> 76 <<
+* ( --- vadr )
+* Compiler/interpreter state.
+ FCB $85
+ FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
+ FCB $C5
+ FDB CURENT-10
+STATE FDB DOUSER
+ FDB XSTATE-UORIG
+*
+* ======>> 77 <<
+* ( --- vadr )
+* Numeric conversion base.
+ FCB $84
+ FCC 'BAS' ; 'BASE' : number base for all input & output
+ FCB $C5
+ FDB STATE-8
+BASE FDB DOUSER
+ FDB XBASE-UORIG
+*
+* ======>> 78 <<
+* ( --- vadr )
+* Decimal point location for output.
+ FCB $83
+ FCC 'DP' ; 'DPL'
+ FCB $CC
+ FDB BASE-7
+DPL FDB DOUSER
+ FDB XDPL-UORIG
+*
+* ======>> 79 <<
+* ( --- vadr )
+* Field width for I/O formatting.
+ FCB $83
+ FCC 'FL' ; 'FLD'
+ FCB $C4
+ FDB DPL-6
+FLD FDB DOUSER
+ FDB XFLD-UORIG
+*
+* ======>> 80 <<
+* ( --- vadr )
+* Compiler stack mark for stack check.
+ FCB $83
+ FCC 'CS' ; 'CSP'
+ FCB $D0
+ FDB FLD-6
+CSP FDB DOUSER
+ FDB XCSP-UORIG
+*
+* ======>> 81 <<
+* ( --- vadr )
+* Editing cursor location.
+ FCB $82
+ FCC 'R' ; 'R#'
+ FCB $A3
+ FDB CSP-6
+RNUM FDB DOUSER
+ FDB XRNUM-UORIG
+*
+* ======>> 82 <<
+* ( --- vadr )
+* Pointer to last HELD character in PAD.
+ FCB $83
+ FCC 'HL' ; 'HLD'
+ FCB $C4
+ FDB RNUM-5
+HLD FDB DOCON
+ FDB XHLD
+*
+* ======>> 82.5 <<== SPECIAL
+* ( --- vadr )
+* Line width of active terminal.
+ FCB $87
+ FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
+ FCB $D3
+ FDB HLD-6
+COLUMS FDB DOUSER
+ FDB XCOLUM-UORIG
+*
+* ######>> screen 38 <<
+**
+** An INCREMENTER probably should not be defined without a defined CONSTANT?
+**
+** Make an INCREMENTER compiling word (not in model):
+** ( n --- )
+** { n INCREMENTER name } typical input
+** CREATE a header and compile the increment constant,
+** then overwrite the header with a call to DOINC.
+* FCB $8B
+* FCC 'INCREMENTE' ; 'INCREMENTER'
+* FCB $D2
+* FDB COLUMS-10
+* INCR FDB DOCOL,CON,PSCODE
+** ( n --- ninc )
+** Characteristic of an INCREMENTER.
+** This is too naive:
+* DOINC LDD ,U
+* ADDD NATWID,X ; Add the increment.
+* STD ,U
+* RTS
+* Compiling word should check that it is compiling a CONSTANT.
+*
+* ======>> 83 <<
+* ( n --- n+1 )
+ FCB $82
+ FCC '1' ; '1+'
+ FCB $AB
+ FDB COLUMS-10
+* Using the model keeps things semantically connected for other processors:
+ONEP FDB DOCOL,ONE,PLUS
+ FDB SEMIS
+** Greedy alternative:
+* ONEP FDB *+NATWID
+* LDD ,U
+* ADDD ONEV,PCR
+* STD ,U
+* RTS
+* Naive alternative:
+* ONEP FDB DOINC
+* FDB 1
+* Naive alternative:
+* ONEP FDB *+NATWID
+* LDD ,U
+* ADDD #1 ; It's hard to imagine 1+ being other than 1.
+* STD ,U
+* RTS
+*
+* ======>> 84 <<
+* ( n --- n+2 )
+ FCB $82
+ FCC '2' ; '2+'
+ FCB $AB
+ FDB ONEP-5
+* Using the model keeps things semantically connected for other processors:
+TWOP FDB DOCOL,TWO,PLUS
+ FDB SEMIS
+** Greedy alternative:
+* TWOP FDB *+NATWID
+* LDD ,U
+* ADDD TWOV,PCR ; See NAT+ (NATP)
+* STD ,U
+* RTS
+* Naive alternative:
+* TWOP FDB DOINC
+* FDB 2
+* Naive alternative:
+* TWOP FDB *+NATWID
+* LDD ,U
+* ADDD #2 ; See NAT+ (NATP)
+* STD ,U
+* RTS
+*
+* ======>> 85 <<
+* ( --- adr )
+* Get the DICTPT allocation, like a USER constant.
+* Should check the stack and heap for collision.
+ FCB $84
+ FCC 'HER' ; 'HERE'
+ FCB $C5
+ FDB TWOP-5
+HERE FDB DOCOL,DICTPT,AT
+ FDB SEMIS
+*
+* ======>> 86 <<
+* ( n --- )
+* Increase/decrease heap (add n to DP),
+* Should ERROR check stack/heap.
+ FCB $85
+ FCC 'ALLO' ; 'ALLOT'
+ FCB $D4
+ FDB HERE-7
+ALLOT FDB DOCOL,DICTPT,PSTORE
+ FDB SEMIS
+*
+* ======>> 87 <<
+* ( n --- )
+* Store word n at DP++,
+* Should ERROR check stack/heap.
+ FCB $81 ; , (COMMA)
+ FCB $AC
+ FDB ALLOT-8
+COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT
+ FDB SEMIS
+* COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
+* FDB SEMIS
+*
+* ======>> 88 <<
+* ( b --- )
+* Store byte b at DP+,
+* Should ERROR check stack/heap.
+ FCB $82
+ FCC 'C' ; 'C,'
+ FCB $AC
+ FDB COMMA-4
+CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
+ FDB SEMIS
+*
+* ======>> 89 <<
+* ( n1 n2 --- n1-n2 )
+* Subtract top two words.
+ FCB $81 ; -
+ FCB $AD
+ FDB CCOMM-5
+SUB FDB *+NATWID
+ LDD NATWID,U ; #2~6
+ SUBD ,U++ ; #2~9
+ STD ,U ; #2~5
+ RTS ; #1~5 = #7~25
+* SUB FDB DOCOL,MINUS,PLUS
+* FDB SEMIS ; Costs 6 bytes and lots of cycles.
+*
+* ======>> 90 <<
+* ( n1 n2 --- n1==n2 )
+* Return flag true if n1 and n2 are equal, otherwise false.
+ FCB $81 =
+ FCB $BD
+ FDB SUB-4
+EQUAL FDB DOCOL,SUB,ZEQU
+ FDB SEMIS
+*
+* ======>> 91 <<
+* ( n1 n2 --- n1<n2 )
+* Return flag true if n1 is less than n2, otherwise false.
+ FCB $81 <
+ FCB $BC
+ FDB EQUAL-4
+LESS FDB *+NATWID
+ LDD NATWID,U
+ SUBD ,U++
+ BGE FALSE
+TRUE LDD #1
+ STD ,U
+ RTS
+FALSE LDD #0
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* CMPA 0,X
+* LEAS 1,S ;
+* BGT LESST
+* BNE LESSF
+* CMPB 1,X ; Why not sub, sbc, bge?
+* BHI LESST
+* LESSF CLRB ;
+* BRA LESSX
+* LESST LDB #1
+* LESSX CLRA ;
+* LEAS 1,S ;
+* JMP PUSHBA
+*
+* ======>> 92 <<
+* ( n1 n2 --- n1>n2 )
+* Return flag true if n1 is greater than n2, false otherwise.
+ FCB $81 >
+ FCB $BE
+ FDB LESS-4
+GREAT FDB DOCOL,SWAP,LESS
+ FDB SEMIS
+*
+* ======>> 93 <<
+* ( n1 n2 n3 --- n2 n3 n1 )
+* Rotate the top three words on stack,
+* bringing the third word to the top.
+ FCB $83
+ FCC 'RO' ; 'ROT'
+ FCB $D4
+ FDB GREAT-4
+ROT FDB *+NATWID
+ PSHS Y
+ PULU D,X,Y
+ PSHU D,X
+ PSHU Y
+ PULS Y,PC
+* ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
+* FDB SEMIS
+*
+* ======>> 94 <<
+* ( --- )
+* EMIT a SPACE.
+ FCB $85
+ FCC 'SPAC' ; 'SPACE'
+ FCB $C5
+ FDB ROT-6
+SPACE FDB DOCOL,BL,EMIT
+ FDB SEMIS
+*
+* ======>> 95 <<
+* ( n0 n1 --- min(n0,n1) )
+* Leave the minimum of the top two integers.
+* Being too greedy here, but, whatever.
+ FCB $83
+ FCC 'MI' ; 'MIN'
+ FCB $CE
+ FDB SPACE-8
+MIN FDB *+NATWID
+ PULU D
+ CMPD ,U
+ BLE MINX
+ STD ,U
+MINX RTS
+* MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
+* FDB MIN2-*-NATWID
+* FDB SWAP
+* MIN2 FDB DROP
+* FDB SEMIS
+*
+* ======>> 96 <<
+* ( n0 n1 --- max(n0,n1) )
+* Leave the maximum of the top two integers.
+* Really should leave this as in the model.
+ FCB $83
+ FCC 'MA' ; 'MAX'
+ FCB $D8
+ FDB MIN-6
+MAX FDB *+NATWID
+ PULU D
+ CMPD ,U
+ BLE MAXX
+ STD ,U
+MAXX RTS
+* MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
+* FDB MAX2-*-NATWID
+* FDB SWAP
+* MAX2 FDB DROP
+* FDB SEMIS
+*
+* ======>> 97 <<
+* ( 0 --- 0 )
+* ( n --- n n )
+* DUP if non-zero.
+ FCB $84
+ FCC '-DU' ; '-DUP'
+ FCB $D0
+ FDB MAX-6
+DDUP FDB *+NATWID
+ LDD ,U
+ BEQ DDUPX
+ PSHU D
+DDUPX RTS
+* DDUP FDB DOCOL,DUP,ZBRAN
+* FDB DDUP2-*-NATWID
+* FDB DUP
+* DDUP2 FDB SEMIS
+*
+* ######>> screen 39 <<
+* ======>> 98.1 <<
+* Supplemental:
+* ( n<0 --- -1 )
+* ( n>=~ --- 1 )
+* Change top integer to its sign.
+ FCB $86
+ FCC 'SIGNU' ; 'SIGNUM'
+ FCB $CD
+ FDB DDUP-7
+SIGNUM FDB *+NATWID
+SIGNUE LDB #1
+ LDA ,U
+ BPL SIGNUP
+ NEGB
+SIGNUP SEX ; Couldn't they have called SignEXtend EXT instead?
+ STD ,U ; Am I too much of a prude?
+ RTS
+* 6800 model version should be something like this:
+* LDB #1
+* CLRA
+* TSX
+* TST ,X
+* BPL SIGNUP
+* NEGB
+* COMA
+* SIGNUP JMP STABX
+*
+* ======>> 98 <<
+* ( adr1 direction --- adr2 )
+* TRAVERSE the symbol name.
+* If direction is 1, find the end.
+* If direction is -1, find the beginning.
+ FCB $88
+ FCC 'TRAVERS' ; 'TRAVERSE'
+ FCB $C5
+ FDB SIGNUM-9
+TRAV FDB *+NATWID
+ BSR SIGNUE ; Convert negative to -, zero or positive to 1.
+ LDD ,U++ ; Still in D, but we have to pop it anyway.
+ LDX ,U ; If D is 1 or -1, so is B.
+ LDA #$7F
+TRAVLP LEAX B,X ; Don't look at the one we start at.
+ CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL.
+ BCC TRAVLP
+TRAVDN STX ,U
+ RTS
+* Doing this in 6809 just because it can be done may be getting too greedy.
+* TRAV FDB DOCOL,SWAP
+* TRAV2 FDB OVER,PLUS,LIT8
+* FCB $7F
+* FDB OVER,CAT,LESS,ZBRAN
+* FDB TRAV2-*-NATWID
+* FDB SWAP,DROP
+* FDB SEMIS
+*
+* ======>> 99 <<
+* ( --- symptr )
+* Fetch CURRENT as a per-USER constant.
+ FCB $86
+ FCC 'LATES' ; 'LATEST'
+ FCB $D4
+ FDB TRAV-11
+LATEST FDB DOCOL,CURENT,AT,AT
+ FDB SEMIS
+* LATEST FDB *+NATWID
+* Getting too greedy:
+* Version 1:
+* TFR DP,A
+* CLRB
+* TFR D,X
+* LDD CURENT+NATWID,PCR
+* LDX [D,X]
+* PSHU X ; Leave the address in X.
+* RTS
+* Version 2:
+* LEAX CURENT,PCR
+* JSR [,X]
+* PULU X
+* LDX [,X]
+* PSHU X
+* RTS
+* Too greedy, too many smantic holes to fall through.
+* If the address at the CFA is made relative,
+* this is part of the code that would be affected
+* if it is in native CPU code.
+*
+* ======>> 100 <<
+* Wanted to do these as INCREMENTERs,
+* but I need to stick with the model as much as possible,
+* (mostly, LOL) adding code only to make the model more clear.
+* ( pfa --- lfa )
+* Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
+ FCB $83
+ FCC 'LF' ; 'LFA'
+ FCB $C1
+ FDB LATEST-9
+LFA FDB DOCOL,LIT8
+* FCB 4
+ FCB 2*NATWID
+ FDB SUB
+ FDB SEMIS
+*
+* ======>> 101 <<
+* ( pfa --- cfa )
+* Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
+ FCB $83
+ FCC 'CF' ; 'CFA'
+ FCB $C1
+ FDB LFA-6
+* CFA FDB DOCOL,TWO,SUB
+CFA FDB DOCOL,NATWC,SUB
+ FDB SEMIS
+*
+* ======>> 102 <<
+* ( pfa --- nfa )
+* Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
+ FCB $83
+ FCC 'NF' ; 'NFA'
+ FCB $C1
+ FDB CFA-6
+NFA FDB DOCOL,LIT8
+* FCB 5
+ FCB NATWID*2+1
+ FDB SUB,ONE,MINUS,TRAV
+ FDB SEMIS
+*
+* ======>> 103 <<
+* ( nfa --- pfa )
+* Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
+ FCB $83
+ FCC 'PF' ; 'PFA'
+ FCB $C1
+ FDB NFA-6
+PFA FDB DOCOL,ONE,TRAV,LIT8
+* FCB 5
+ FCB NATWID*2+1
+ FDB PLUS
+ FDB SEMIS
+*
+* ######>> screen 40 <<
+* ======>> 104 <<
+* ( --- )
+* Save the parameter stack pointer in CSP for compiler checks.
+ FCB $84
+ FCC '!CS' ; '!CSP'
+ FCB $D0
+ FDB PFA-6
+SCSP FDB DOCOL,SPAT,CSP,STORE
+ FDB SEMIS
+*
+* ======>> 105 <<
+* ( 0 n --- ) ( *** )
+* ( true n --- IN BLK ) ( anything *** nothing )
+* If flag is false, do nothing.
+* If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
+* Leaves cursor position (IN)
+* and currently loading block number (BLK) on stack, for analysis.
+*
+* This one is too important to be high-level Forth codes.
+* When we have an error, we want to disturb as little as possible.
+* But fixing that cascades through ERROR and MESSAGE
+* into the disk block system.
+* And we aren't ready for that yet.
+ FCB $86
+ FCC '?ERRO' ; '?ERROR'
+ FCB $D2
+ FDB SCSP-7
+* QERR FDB *+NATWID
+* LDD NATWID,U
+* BNE QERROR
+* LEAU 2*NATWID,U
+* RTS
+** this doesn't work anyway: QERROR LBR ERROR
+QERR FDB DOCOL,SWAP,ZBRAN
+ FDB QERR2-*-NATWID
+ FDB ERROR,BRAN
+ FDB QERR3-*-NATWID
+QERR2 FDB DROP
+QERR3 FDB SEMIS
+*
+* ======>> 106 <<
+* STATE is compiling:
+* ( --- ) ( *** )
+* STATE is compiling:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not compiling.
+ FCB $85
+ FCC '?COM' ; '?COMP'
+ FCB $D0
+ FDB QERR-9
+QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8
+ FCB $11
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 107 <<
+* STATE is executing:
+* ( --- ) ( *** )
+* STATE is executing:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not executing.
+ FCB $85
+ FCC '?EXE' ; '?EXEC'
+ FCB $C3
+ FDB QCOMP-8
+QEXEC FDB DOCOL,STATE,AT,LIT8
+ FCB $12
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 108 <<
+* ( n1 n1 --- ) ( *** )
+* ( n1 n2 --- IN BLK ) ( anything *** nothing )
+* ERROR if top two are unequal.
+* MESSAGE says compiled conditionals do not match.
+ FCB $86
+ FCC '?PAIR' ; '?PAIRS'
+ FCB $D3
+ FDB QEXEC-8
+QPAIRS FDB DOCOL,SUB,LIT8
+ FCB $13
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 109 <<
+* CSP and parameter stack are balanced (equal):
+* ( --- ) ( *** )
+* CSP and parameter stack are not balanced (unequal):
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if return/control stack is not at same level as last !CSP.
+* Usually indicates that a definition has been left incomplete.
+ FCB $84
+ FCC '?CS' ; '?CSP'
+ FCB $D0
+ FDB QPAIRS-9
+QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8
+ FCB $14
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 110 <<
+* Active BLK input:
+* ( --- ) ( *** )
+* No active BLK input:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not loading, i. e., if BLK is zero.
+ FCB $88
+ FCC '?LOADIN' ; '?LOADING'
+ FCB $C7
+ FDB QCSP-7
+QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8
+ FCB $16
+ FDB QERR
+ FDB SEMIS
+*
+* ######>> screen 41 <<
+* ======>> 111 <<
+* ( --- )
+* Compile an in-line literal value from the instruction stream.
+ FCB $87
+ FCC 'COMPIL' ; 'COMPILE'
+ FCB $C5
+ FDB QLOAD-11
+* COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
+* COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
+COMPIL FDB DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
+ FDB SEMIS
+*
+* ======>> 112 <<
+* ( --- ) P
+* Clear the compile state bit(s) (shift to interpret).
+ FCB $C1 [ immediate
+ FCB $DB
+ FDB COMPIL-10
+LBRAK FDB DOCOL,ZERO,STATE,STORE
+ FDB SEMIS
+*
+* ======>> 113 <<
+*
+STCOMP EQU $C0
+* ( --- )
+* Set the compile state bit(s) (shift to compile).
+ FCB $81 ]
+ FCB $DD
+ FDB LBRAK-4
+RBRAK FDB DOCOL,LIT8
+ FCB STCOMP
+ FDB STATE,STORE
+ FDB SEMIS
+*
+* ======>> 114 <<
+* ( --- )
+* Toggle SMUDGE bit of LATEST definition header,
+* to hide it until defined or reveal it after definition.
+ FCB $86
+ FCC 'SMUDG' ; 'SMUDGE'
+ FCB $C5
+ FDB RBRAK-4
+SMUDGE FDB DOCOL,LATEST,LIT8
+ FCB FSMUDG
+ FDB TOGGLE
+ FDB SEMIS
+*
+* ======>> 115 <<
+* ( --- )
+* Set the conversion base to sixteen (b00010000).
+ FCB $83
+ FCC 'HE' ; 'HEX'
+ FCB $D8
+ FDB SMUDGE-9
+HEX FDB DOCOL
+ FDB LIT8
+ FCB 16 ; decimal sixteen
+ FDB BASE,STORE
+ FDB SEMIS
+*
+* ======>> 116 <<
+* ( --- )
+* Set the conversion base to ten (b00001010).
+ FCB $87
+ FCC 'DECIMA' ; 'DECIMAL'
+ FCB $CC
+ FDB HEX-6
+DEC FDB DOCOL
+ FDB LIT8
+ FCB 10 ; decimal ten
+ FDB BASE,STORE
+ FDB SEMIS
+*
+* ######>> screen 42 <<
+* ======>> 117 <<
+* ( --- ) ( IP *** )
+* Pop the saved IP and use it to
+* compile the latest symbol as a reference to a ;CODE definition;
+* overwrite the code field of the symbol found by LATEST
+* with the address of the low-level characteristic code
+* provided in the defining definition.
+* Look closely at where things return, consider the operation of R> and >R .
+*
+* The machine-level code which follows (;CODE) in the instruction stream
+* is not executed by the defining symbol,
+* but becomes the characteristic of the defined symbol.
+* This is the usual way to generate the characteristics of VARIABLEs,
+* CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
+*
+* Finally, note that, if code shifts from low level back to high
+* (native CPU machine code calling into a list of FORTH codes),
+* the low level code can't just call a high-level definition.
+* Leaf definitions can directly call other leaf definitions,
+* but not non-leafs.
+* It will need an anonymous list, probably embedded in the low-level code,
+* and Y and X will have to be set appropriately before entering the list.
+ FCB $87
+ FCC '(;CODE' ; '(;CODE)'
+ FCB $A9
+ FDB DEC-10
+* PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
+PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+ FDB LATEST,PFA,CFA,STORE
+ FDB SEMIS
+*
+* ======>> 118 <<
+* ( --- ) P
+* ?CSP to see if there are loose ends in the defining definition
+* before shifting to the assembler,
+* compile (;CODE) in the defining definition's instruction stream,
+* shift to interpreting,
+* make the ASSEMBLER vocabulary current,
+* and !CSP to mark the stack
+* in preparation for assembling low-level code.
+* Note that ;CODE, unlike DOES>, is IMMEDIATE,
+* and compiles (;CODE),
+* which will do the actual work of changing
+* the LATEST definition's characteristic when the defining word runs.
+* Assembly is done by the interpreter, rather than the compiler.
+* I could have avoided the anomalous three-byte code fields by
+*
+* Note that the ASSEMBLER is not part of the model (at this time).
+* That means that, until the assembler is ready,
+* if you want to define low-level words,
+* you have to poke (comma) in hand-assembled stuff.
+*
+ FCB $C5 immediate
+ FCC ';COD' ; ';CODE'
+ FCB $C5
+ FDB PSCODE-10
+SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
+ FDB SEMIS
+* note: "QSTACK" will be replaced by "ASSEMBLER" later
+*
+* ######>> screen 43 <<
+* ======>> 119 <<
+* ( --- ) C
+* Make the word currently being defined
+* build a header for DOES> definitions.
+* Actually just compiles a CONSTANT zero
+* which can be overwritten later by DOES>.
+* Since the fig models were established, this technique has been deprecated.
+*
+* Note that <BUILDS is not IMMEDIATE,
+* and therefore executes during a definition's run-time,
+* rather than its compile-time.
+* It is not intended to be used directly,
+* but rather so that one definition word can build another.
+* Also, note that nothing particularly special happens
+* in the defining definition until DOES> executes.
+* The name <BUILDS is intended to be a reminder of what is about to occur.
+*
+* <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
+ FCB $87
+ FCC '<BUILD' ; '<BUILDS'
+ FCB $D3
+ FDB SEMIC-8
+BUILDS FDB DOCOL,ZERO,CON
+ FDB SEMIS
+*
+* ======>> 120 <<
+* ( --- ) ( IP *** ) C
+* Define run-time behavior of definitions compiled/defined
+* by a high-level defining definition --
+* the FORTH equivalent of a compiler-compiler.
+* DOES> assumes that the LATEST symbol table entry
+* has at least one word of parameter field,
+* which <BUILDS provides.
+* Note that DOES> is also not IMMEDIATE.
+*
+* When the defining word containing DOES> executes the DOES> icode,
+* it overwrites the LATEST symbol's CFA with jsr <XDOES,
+* overwrites the first word of that symbol's parameter field with its own IP,
+* and pops the previous IP from the return stack.
+* The icodes which follow DOES> in the stream
+* do not execute at the defining word's run-time.
+*
+* Examining XDOES in the virtual machine shows
+* that the defined word will execute those icodes
+* which follow DOES> at its own run-time.
+*
+* The advantage of this kind of behaviour,
+* which you will also note in ;CODE,
+* is that the defined word can contain
+* both operations and data to be operated on.
+* This is how FORTH data objects define their own behavior.
+*
+* Finally, note that the effective parameter field for DOES> definitions
+* starts two NATWID words after the CFA, instead of just one
+* (four bytes instead of two in a sixteen-bit addressing Forth).
+*
+* VOCABULARYs will use this. See definition of word FORTH.
+ FCB $85
+ FCC 'DOES' ; 'DOES>'
+ FCB $BE
+ FDB BUILDS-10
+* DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
+DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+ FDB LATEST,PFA,STORE
+ FDB PSCODE
+*
+* ( --- PFA+NATWID ) ( *** IP )
+* Characteristic of a DOES> defined word.
+* The characteristics of DOES> definitions are written in high-level
+* Forth codes rather than native CPU machine level code.
+* The first parameter word points to the high-level characteristic.
+* This routine's job is to push the IP,
+* load the high level characteristic pointer in IP,
+* and leave the address following the characteristic pointer on the stack
+* so the parameter field can be accessed.
+DODOES LDD ,S ; Keep the return address.
+ STY ,S ; Save/nest the current IP on the return stack.
+ LDY NATWID,X ; First parameter is new IP.
+ LEAX 2*NATWID,X ; Address of second parameter.
+ PSHU X
+ TFR D,PC ; Synthetic return.
+*
+* From the 6800 model:
+* DODOES LDA IP
+* LDB IP+1
+* LDX RP make room on return stack
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* STA 2,X push return address
+* STB 3,X
+* LDX W get addr of pointer to run-time code
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX N stash it in scratch area
+* LDX 0,X get new IP
+* STX IP
+* CLRA ; get address of parameter
+* LDB #2
+* ADDB N+1
+* ADCA N
+* PSHS B ; and push it on data stack
+* PSHS A ;
+* JMP NEXT2
+*
+* ######>> screen 44 <<
+* ======>> 121 <<
+* ( strptr --- strptr+1 count )
+* Convert counted string to string and count.
+* (Fetch the byte at strptr, post-increment.)
+ FCB $85
+ FCC 'COUN' ; 'COUNT'
+ FCB $D4
+ FDB DOES-8
+COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
+ FDB SEMIS
+*
+* ======>> 122 <<
+* ( strptr count --- )
+* EMIT count characters at strptr.
+ FCB $84
+ FCC 'TYP' ; 'TYPE'
+ FCB $C5
+ FDB COUNT-8
+TYPE FDB DOCOL,DDUP,ZBRAN
+ FDB TYPE3-*-NATWID
+ FDB OVER,PLUS,SWAP,XDO
+TYPE2 FDB I,CAT,EMIT,XLOOP
+ FDB TYPE2-*-NATWID
+ FDB BRAN
+ FDB TYPE4-*-NATWID
+TYPE3 FDB DROP
+TYPE4 FDB SEMIS
+*
+* ======>> 123 <<
+* ( strptr count1 --- strptr count2 )
+* Supress trailing blanks (subtract count of trailing blanks from strptr).
+ FCB $89
+ FCC '-TRAILIN' ; '-TRAILING'
+ FCB $C7
+ FDB TYPE-7
+DTRAIL FDB DOCOL,DUP,ZERO,XDO
+DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
+ FDB SUB,ZBRAN
+ FDB DTRAL3-*-NATWID
+ FDB LEAVE,BRAN
+ FDB DTRAL4-*-NATWID
+DTRAL3 FDB ONE,SUB
+DTRAL4 FDB XLOOP
+ FDB DTRAL2-*-NATWID
+ FDB SEMIS
+*
+* ======>> 124 <<
+* ( --- )
+* TYPE counted string out of instruction stream (updating IP).
+ FCB $84
+ FCC '(."' ; '(.")'
+ FCB $A9
+ FDB DTRAIL-12
+* PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
+* PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
+PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP
+ FDB FROMR,PLUS,TOR,TYPE
+ FDB SEMIS
+*
+* ======>> 125 <<
+* ( --- ) P
+* { ." something-to-be-printed " } typical input
+* Use WORD to parse to trailing quote;
+* if compiling, compile XDOTQ and string parsed,
+* otherwise, TYPE string.
+ FCB $C2 immediate
+ FCC '.' ; '."'
+ FCB $A2
+ FDB PDOTQ-7
+DOTQ FDB DOCOL
+ FDB LIT8
+ FCB $22 ascii quote
+ FDB STATE,AT,ZBRAN
+ FDB DOTQ1-*-NATWID
+ FDB COMPIL,PDOTQ,WORD
+ FDB HERE,CAT,ONEP,ALLOT,BRAN
+ FDB DOTQ2-*-NATWID
+DOTQ1 FDB WORD,HERE,COUNT,TYPE
+DOTQ2 FDB SEMIS
+*
+* ######>> screen 45 <<
+* ======>> 126 <<== MACHINE DEPENDENT
+* ( --- ) ( *** )
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if parameter stack out of bounds.
+*
+* But checking whether the stack is in bounds or not
+* really should not use the stack.
+* And there really should be a ?RSTACK, as well.
+ FCB $86
+ FCC '?STAC' ; '?STACK'
+ FCB $CB
+ FDB DOTQ-5
+QSTACK FDB DOCOL,LIT8
+* FCB $12
+ FCB SINIT-ORIG
+* But why use that instead of XSPZER (S0)?
+* Multi-user or multi-tasking would not want that.
+* CMPU <XSPZER
+* FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
+ FDB PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
+ FDB QERR
+* prints 'empty stack'
+*
+QSTAC2 FDB SPAT
+* Here, we compare with a value at least 128
+* higher than dict. ptr. (DICTPT)
+ FDB HERE,LIT8
+ FCB $80 ; This is a rough check anyway, leave it as is.
+ FDB PLUS,LESS,ZBRAN
+ FDB QSTAC3-*-NATWID
+ FDB TWO ; NOT the NATWID constant!
+ FDB QERR
+* prints 'full stack'
+*
+QSTAC3 FDB SEMIS
+*
+* ======>> 127 << this word's function
+* is done by ?STACK in this version
+* FCB $85
+* FCC 4,?FREE
+* FCB $C5
+* FDB QSTACK-9
+*QFREE FDB DOCOL,SPAT,HERE,LIT8
+* FCB $80
+* FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
+*
+* ######>> screen 46 <<
+* ======>> 128 <<
+* ( buffer n --- )
+* ***** Check that this is how it works here:
+* Get up to n-1 characters from the keyboard,
+* storing at buffer and echoing, with backspace editing,
+* quitting when a CR is read.
+* Terminate it with a NUL.
+ FCB $86
+ FCC 'EXPEC' ; 'EXPECT'
+ FCB $D4
+ FDB QSTACK-9
+EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
+* EXPEC2 FDB KEY,DUP,LIT8
+EXPEC2 FDB KEY
+* FDB LIT,$1C,SHOTOS ; DBG
+ FDB DUP,LIT8
+ FCB BACKSP-ORIG
+ FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing
+ FDB EXPEC3-*-NATWID
+ FDB DROP,LIT8
+ FCB 8 ( backspace character to emit )
+ FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
+ FDB TOR,SUB,BRAN
+ FDB EXPEC6-*-NATWID
+EXPEC3 FDB DUP,LIT8
+ FCB $D ( carriage return )
+ FDB EQUAL,ZBRAN
+ FDB EXPEC4-*-NATWID
+ FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
+ FDB EXPEC5-*-NATWID
+EXPEC4 FDB DUP
+EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
+EXPEC6 FDB EMIT,XLOOP
+ FDB EXPEC2-*-NATWID
+ FDB DROP
+ FDB SEMIS
+*
+* ======>> 129 <<
+* ( --- )
+* EXPECT 128 (TWID) characters to TIB.
+ FCB $85
+ FCC 'QUER' ; 'QUERY'
+ FCB $D9
+ FDB EXPECT-9
+QUERY FDB DOCOL,TIB,AT,COLUMS
+ FDB AT,EXPECT,ZERO,IN,STORE
+ FDB SEMIS
+*
+* ======>> 130 <<
+* ( --- ) P
+* End interpretation of a line or screen, and/or prepare for a new block.
+* Note that the name of this definition is an empty string,
+* so it matches on the terminating NUL in the terminal or block buffer.
+ FCB $C1 immediate < carriage return >
+ FCB $80
+ FDB QUERY-8
+NULL FDB DOCOL,BLK,AT,ZBRAN
+ FDB NULL2-*-NATWID
+ FDB ONE,BLK,PSTORE
+ FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
+ FDB ZEQU
+* check for end of screen
+ FDB ZBRAN
+ FDB NULL1-*-NATWID
+ FDB QEXEC,FROMR,DROP
+NULL1 FDB BRAN
+ FDB NULL3-*-NATWID
+NULL2 FDB FROMR,DROP
+NULL3 FDB SEMIS
+*
+* ######>> screen 47 <<
+* ======>> 133 <<
+* ( adr n b --- )
+* Fill n bytes at adr with b.
+* This relies on CMOVE having a certain lack of parameter checking,
+* where overlapping regions are not properly inverted in copy.
+* And this really should be done in low-level.
+* None of the advantages of doing things in high-level apply to fill.
+ FCB $84
+ FCC 'FIL' ; 'FILL'
+ FCB $CC
+ FDB NULL-4
+FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
+ FDB FROMR,ONE,SUB,CMOVE
+ FDB SEMIS
+*
+* ======>> 134 <<
+* ( adr n --- )
+* Fill n bytes with 0.
+ FCB $85
+ FCC 'ERAS' ; 'ERASE'
+ FCB $C5
+ FDB FILL-7
+ERASE FDB DOCOL,ZERO,FILL
+ FDB SEMIS
+*
+* ======>> 135 <<
+* ( adr n --- )
+* Fill n bytes with ASCII SPACE.
+ FCB $86
+ FCC 'BLANK' ; 'BLANKS'
+ FCB $D3
+ FDB ERASE-8
+BLANKS FDB DOCOL,BL,FILL
+ FDB SEMIS
+*
+* ======>> 136 <<
+* ( c --- )
+* Format a character at the left of the HLD output buffer.
+ FCB $84
+ FCC 'HOL' ; 'HOLD'
+ FCB $C4
+ FDB BLANKS-9
+HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
+ FDB SEMIS
+*
+* ======>> 137 <<
+* ( --- adr )
+* Give the address of the output PAD buffer.
+* PAD points to the end of a 68 byte buffer for numeric conversion.
+ FCB $83
+ FCC 'PA' ; 'PAD'
+ FCB $C4
+ FDB HOLD-7
+PAD FDB DOCOL,HERE,LIT8
+ FCB $44
+ FDB PLUS
+ FDB SEMIS
+*
+* ######>> screen 48 <<
+* ======>> 138 <<
+* ( c --- )
+* Scan a string terminated by the character c or ASCII NUL out of input;
+* store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
+* Leading c are passed over, per ENCLOSE.
+* Scans from BLK, or from TIB if BLK is zero.
+* May overwrite the numeric conversion pad,
+* if really long (length > 31) symbols are scanned.
+ FCB $84
+ FCC 'WOR' ; 'WORD'
+ FCB $C4
+ FDB PAD-6
+WORD FDB DOCOL,BLK,AT,ZBRAN
+ FDB WORD2-*-NATWID
+ FDB BLK,AT,BLOCK,BRAN
+ FDB WORD3-*-NATWID
+WORD2 FDB TIB,AT
+WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
+ FCB 34
+ FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
+ FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
+ FDB SEMIS
+*
+* ######>> screen 49 <<
+* ======>> 139 <<
+* ( d1 string --- d2 adr )
+* Convert the text at string into a number, accumulating the result into d1,
+* leaving adr pointing to the first character not converted.
+* If DPL is non-negative at entry,
+* accumulates the number of characters converted into DPL.
+ FCB $88
+ FCC '(NUMBER' ; '(NUMBER)'
+ FCB $A9
+ FDB WORD-7
+PNUMB FDB DOCOL
+PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
+ FDB PNUMB4-*-NATWID
+ FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
+ FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
+ FDB PNUMB3-*-NATWID
+ FDB ONE,DPL,PSTORE
+PNUMB3 FDB FROMR,BRAN
+ FDB PNUMB2-*-NATWID
+PNUMB4 FDB FROMR
+ FDB SEMIS
+*
+* ======>> 140 <<
+* ( ctstr --- d )
+* Convert text at ctstr to a double integer,
+* taking the 0 ERROR if the conversion is not valid.
+* If a decimal point is present,
+* accumulate the count of digits to the decimal point's right into DPL
+* (negative DPL at exit indicates single precision).
+* ctstr is a counted string
+* -- the first byte at ctstr is the length of the string,
+* but NUMBER ignores the count and expects a NUL terminator instead.
+ FCB $86
+ FCC 'NUMBE' ; 'NUMBER'
+ FCB $D2
+ FDB PNUMB-11
+NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
+ FCC "-" minus sign
+ FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
+NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
+ FDB ZBRAN
+ FDB NUMB2-*-NATWID
+ FDB DUP,CAT,LIT8
+ FCC "."
+ FDB SUB,ZERO,QERR,ZERO,BRAN
+ FDB NUMB1-*-NATWID
+NUMB2 FDB DROP,FROMR,ZBRAN
+ FDB NUMB3-*-NATWID
+ FDB DMINUS
+NUMB3 FDB SEMIS
+*
+* ======>> 141 <<
+* ( --- locptr length true ) { -FIND name } typical input
+* ( --- false )
+* Parse a word, then FIND,
+* first in the definition vocabulary,
+* then in the CONTEXT (interpretation) vocabulary, if necessary.
+* Returns what (FIND) returns, flag and optional location and length.
+ FCB $85
+ FCC '-FIN' ; '-FIND'
+ FCB $C4
+ FDB NUMB-9
+DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
+ FDB PFIND,DUP,ZEQU,ZBRAN
+ FDB DFIND2-*-NATWID
+ FDB DROP,HERE,LATEST,PFIND
+DFIND2 FDB SEMIS
+*
+* ######>> screen 50 <<
+* ======>> 142 <<
+* ( anything --- nothing ) ( anything *** nothing )
+* An indirection for ABORT, for ERROR,
+* which may be modified carefully.
+ FCB $87
+ FCC '(ABORT' ; '(ABORT)'
+ FCB $A9
+ FDB DFIND-8
+PABORT FDB DOCOL,ABORT
+ FDB SEMIS
+*
+* ======>> 143 <<
+ FCB $85
+ FCC 'ERRO' ; 'ERROR'
+ FCB $D2
+ FDB PABORT-10
+* This really should not be high level, according to best practices.
+* But fixing that cascades through MESSAGE,
+* requiring re-architecting the disk block system.
+* First, we need to get this transliteration running.
+ERROR FDB DOCOL,WARN,AT,ZLESS
+ FDB ZBRAN
+ FDB ERROR2-*-NATWID
+* note: WARNING is
+* -1 to abort,
+* 0 to print error #
+* and 1 to print error message from disc
+ FDB PABORT
+ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
+ FCB 4,7 ( bell )
+ FCC " ? "
+ FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
+ FDB SEMIS
+*
+* ======>> 144 <<
+* ( n adr --- )
+* Mask byte at adr with n.
+* Not in FIG, don't need it for 8 bit characters after all.
+* FCB $85
+* FCC 'CMAS' ; 'CMASK'
+* FCB $CB ; 'K'
+* FDB ERROR-8
+* CMASK FDB *+NATWID
+* LDX ,U++ ; adr
+* LDD ,U++ ; mask
+* ANDB ,X
+* STB ,X
+* RTS
+*
+* ( adr --- adr )
+* Mask high bit of tail of name in PAD buffer.
+* Not in FIG, need it for 8 bit characters.
+ FCB $86
+ FCC 'IDFLA' ; 'IDFLAT'
+ FCB $D4 ; 'T'
+ FDB ERROR-8
+IDFLAT FDB *+NATWID
+ LDX ,U
+ LDB ,X ; get the count
+ ANDB #CTMASK
+ LDA B,X ; point to the tail
+ ANDA #$7F ; Clear the EndOfName flag bit.
+ STA B,X
+ RTS
+*
+* ( symptr --- )
+* Print definition's name from its NFA.
+ FCB $83
+ FCC 'ID' ; 'ID.'
+ FCB $AE
+ FDB IDFLAT-9
+IDDOT FDB DOCOL,PAD,LIT8
+ FCB 32
+ FDB LIT8
+ FCB $5F ( underline )
+ FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
+* FDB SWAP,CMOVE,PAD,COUNT,LIT8
+ FDB SWAP,CMOVE,PAD
+ FDB IDFLAT
+ FDB COUNT,LIT8
+ FCB 31
+ FDB AND,TYPE,SPACE
+ FDB SEMIS
+*
+* ######>> screen 51 <<
+* ======>> 145 <<
+* ( --- ) { CREATE name } input
+* Parse a name (length < 32 characters) and create a header,
+* reporting first duplicate found in either the defining vocabulary
+* or the context (interpreting) vocabulary.
+* Install the header in the defining vocabulary
+* with CFA dangerously pointing to the parameter field.
+* Leave the name SMUDGEd.
+ FCB $86
+ FCC 'CREAT' ; 'CREATE'
+ FCB $C5
+ FDB IDDOT-6
+CREATE FDB DOCOL,DFIND,ZBRAN
+ FDB CREAT2-*-NATWID
+ FDB DROP,PDOTQ
+ FCB 8
+ FCB 7 ( bel )
+ FCC "redef: "
+ FDB NFA,IDDOT,LIT8
+ FCB 4
+ FDB MESS,SPACE
+CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
+ FDB ONEP,ALLOT,DUP,LIT8
+ FCB ($80|FSMUDG) ; Bracket the name.
+ FDB TOGGLE,HERE,ONE,SUB,LIT8
+ FCB $80
+ FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
+* FDB HERE,TWOP,COMMA
+ FDB HERE,NATP,COMMA
+ FDB SEMIS
+*
+* ######>> screen 52 <<
+* ======>> 146 <<
+* ( --- ) P
+* { [COMPILE] name } typical use
+* -DFIND next WORD and COMPILE it, literally;
+* used to compile immediate definitions into words.
+ FCB $C9 immediate
+ FCC '[COMPILE' ; '[COMPILE]'
+ FCB $DD
+ FDB CREATE-9
+BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
+ FDB SEMIS
+*
+* ======>> 147 <<
+* ( n --- ) if compiling. P
+* ( n --- n ) if interpreting.
+* Compile n as a literal, if compiling.
+ FCB $C7 immediate
+ FCC 'LITERA' ; 'LITERAL'
+ FCB $CC
+ FDB BCOMP-12
+LITER FDB DOCOL,STATE,AT,ZBRAN
+ FDB LITER2-*-NATWID
+ FDB COMPIL,LIT,COMMA
+LITER2 FDB SEMIS
+*
+* ======>> 148 <<
+* ( d --- ) if compiling. P
+* ( d --- d ) if interpreting.
+* Compile d as a double literal, if compiling.
+ FCB $C8 immediate
+ FCC 'DLITERA' ; 'DLITERAL'
+ FCB $CC
+ FDB LITER-10
+DLITER FDB DOCOL,STATE,AT,ZBRAN
+ FDB DLITE2-*-NATWID
+ FDB SWAP,LITER,LITER ; Just two literals in the right order.
+DLITE2 FDB SEMIS
+*
+* ######>> screen 53 <<
+* ======>> 149 <<
+* ( --- )
+* Interpret or compile, according to STATE.
+* Searches words parsed in dictionary first, via -FIND,
+* then checks for valid NUMBER.
+* Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
+* ERROR checks the stack via ?STACK before returning to its caller.
+ FCB $89
+ FCC 'INTERPRE' ; 'INTERPRET'
+ FCB $D4
+ FDB DLITER-11
+INTERP FDB DOCOL
+INTER2 FDB DFIND,ZBRAN
+ FDB INTER5-*-NATWID
+ FDB STATE,AT,LESS
+ FDB ZBRAN
+ FDB INTER3-*-NATWID
+ FDB CFA,COMMA,BRAN
+ FDB INTER4-*-NATWID
+INTER3 FDB CFA,EXEC
+INTER4 FDB BRAN
+ FDB INTER7-*-NATWID
+INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
+ FDB INTER6-*-NATWID
+ FDB DLITER,BRAN
+ FDB INTER7-*-NATWID
+INTER6 FDB DROP,LITER
+INTER7 FDB QSTACK,BRAN
+ FDB INTER2-*-NATWID
+* FDB SEMIS never executed
+
+*
+* ######>> screen 54 <<
+* ======>> 150 <<
+* ( --- )
+* Toggle precedence bit of LATEST definition header.
+* During compiling, most symbols scanned are compiled.
+* IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
+* but may be compiled via ' (TICK).
+ FCB $89
+ FCC 'IMMEDIAT' ; 'IMMEDIATE'
+ FCB $C5
+ FDB INTERP-12
+IMMED FDB DOCOL,LATEST,LIT8
+ FCB FIMMED
+ FDB TOGGLE
+ FDB SEMIS
+*
+* ======>> 151 <<
+* ( --- ) { VOCABULARY name } input
+* Create a vocabulary entry with a flag for terminating vocabulary searches.
+* Store the current search context in it for linking.
+* At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
+ FCB $8A
+ FCC 'VOCABULAR' ; 'VOCABULARY'
+ FCB $D9
+ FDB IMMED-12
+VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
+ FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
+* DOVOC FDB TWOP,CONTXT,STORE
+DOVOC FDB NATP,CONTXT,STORE
+ FDB SEMIS
+*
+* ======>> 152 <<
+*
+* Note: FORTH does not go here in the rom-able dictionary,
+* since FORTH is a type of variable.
+*
+* (Should make a proper architecture for this at some point.)
+*
+*
+* ======>> 153 <<
+* ( --- )
+* Makes the current interpretation CONTEXT vocabulary
+* also the CURRENT defining vocabulary.
+ FCB $8B
+ FCC 'DEFINITION' ; 'DEFINITIONS'
+ FCB $D3
+ FDB VOCAB-13
+DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
+ FDB SEMIS
+*
+* ======>> 154 <<
+* ( --- )
+* Parse out a comment and toss it away.
+* Leaves the first 32 characters in WORDPAD, which may or may not be useful.
+ FCB $C1 immediate (
+ FCB $A8
+ FDB DEFIN-14
+PAREN FDB DOCOL,LIT8
+ FCC ")"
+ FDB WORD
+ FDB SEMIS
+*
+* ######>> screen 55 <<
+* ======>> 155 <<
+* ( anything *** nothing )
+* Clear return stack.
+* Then INTERPRET and, if not compiling, prompt with OK,
+* in infinite loop.
+ FCB $84
+ FCC 'QUI' ; 'QUIT'
+ FCB $D4
+ FDB PAREN-4
+QUIT FDB DOCOL,ZERO,BLK,STORE
+ FDB LBRAK
+*
+* Here is the outer interpretter
+* which gets a line of input, does it, prints " OK"
+* then repeats :
+QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
+ FDB ZBRAN
+ FDB QUIT3-*-NATWID
+ FDB PDOTQ
+ FCB 3
+ FCC ' OK' ; ' OK'
+QUIT3 FDB BRAN
+ FDB QUIT2-*-NATWID
+* FDB SEMIS ( never executed )
+*
+* ======>> 156 <<
+* ( anything --- nothing ) ( anything *** nothing )
+* Clear parameter stack,
+* set STATE to interpret and BASE to DECIMAL,
+* return to input from terminal,
+* restore DRIVE OFFSET to 0,
+* print out "Forth-68",
+* set interpret and define vocabularies to FORTH,
+* and finally, QUIT.
+* Used to force the system to a known state
+* and return control to the initial INTERPRETer.
+ FCB $85
+ FCC 'ABOR' ; 'ABORT'
+ FCB $D4
+ FDB QUIT-7
+ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
+ FCB 19
+ FCC "fig-Forth-6809(RTS)"
+ FDB FORTH,DEFIN
+ FDB QUIT
+* FDB SEMIS never executed
+ PAGE
+*
+* ######>> screen 56 <<
+* bootstrap code... moves rom contents to ram :
+* ======>> 157 <<
+ FCB $84
+ FCC 'COL' ; 'COLD'
+ FCB $C4
+ FDB ABORT-8
+COLD FDB *+NATWID
+* Ultimately, we want position indepence,
+* so I'm using PCR where it seems reasonable.
+CENT LDS SINIT,PCR ; Get a useable return stack, at least.
+ LDA #IUPDP ; This is not relative to PC.
+ TFR A,DP ; And a useable direct page, too.
+ SETDP IUPDP ; (For good measure.)
+*
+* We'll keep this here for the time being.
+* There are better ways to do this, of course.
+* Re-architect, re-architect.
+ LEAX ERAM,PCR ; end of stuff to move
+ STX <XFENCE ; Borrow this variable for a loop terminator.
+ LDY #RBEG ; bottom of open-ended destination
+ LEAX RAM,PCR ; bottom of stuff to move
+COLD2 LDA ,X+
+ STA ,Y+ ; move TASK & FORTH to ram
+ CMPX <XFENCE
+ BNE COLD2
+* Leaves USE and PREV uninitialized.
+ LDX BUFINT,PCR
+ STX <XUSE
+ STX <XPREV
+* LEAX RAM,PCR
+* STX <XFENCE ; Borrow this variable for a loop terminator.
+* LEAY REND,PCR ; top of destination (included XUSE and XPREV)
+* LEAX ERAM,PCR ; top of stuff to move (included initializers for XUSE and XPREV)
+* COLD2 LDA ,-X
+* STA ,-Y ; move TASK & FORTH to ram
+* CMPX <XFENCE
+* BNE COLD2
+*
+* CENT LDS #REND-1 top of destination
+* LDX #ERAM top of stuff to move
+* COLD2 LEAX -1,X ;
+* LDA 0,X
+* PSHS A ; move TASK & FORTH to ram
+* CMPX #RAM
+* BNE COLD2
+*
+* LDS #XFENCE-1 put stack at a safe place for now
+* But that is taken care of.
+* LDX COLINT
+* STX XCOLUM
+ LDX COLINT,PCR
+ STX <XCOLUM
+* LDX DELINT
+* STX XDELAY
+ LDX DELINT,PCR
+ STX <XDELAY
+* LDX VOCINT
+* STX XVOCL
+ LDX VOCINT,PCR
+ STX <XVOCL
+* LDX DPINIT
+* STX XDICTP
+ LDX DPINIT,PCR
+ STX <XDICTP
+* LDX FENCIN
+* STX XFENCE
+ LDX FENCIN,PCR
+ STX <XFENCE
+*
+WENT LDS SINIT,PCR ; Get a useable return stack, at least.
+ LDA #IUPDP ; This is not relative to PC.
+ TFR A,DP ; And a useable direct page, too.
+ SETDP IUPDP ; (For good measure.)
+*
+ LEAX SINIT,PCR
+ PSHS X ; for loop termination
+ CLRB ; Yes, I'm being a little ridiculous. Only a little.
+ TFR D,Y
+ LEAY XFENCE-UORIG,Y ; top of destination
+ LEAX FENCIN,PCR ; top of stuff to move
+WARM2 LDD ,--X ; All entries are 16 bit.
+ STD ,--Y
+ CMPX ,S
+ BNE WARM2
+ LEAS 2,S ; But we'll reset the return stack shortly, anyway.
+ LDU <XSPZER ; So we can clear the hole above the TOS
+* WENT LDS #XFENCE-1 top of destination
+* LDX #FENCIN top of stuff to move
+* WARM2 LEAX -1,X ;
+* LDA 0,X
+* PSHS A ;
+* CMPX #SINIT
+* BNE WARM2
+*
+* LDS SINIT
+* S is already there.
+* LDX UPINIT
+* STX UP init user ram pointer
+* UP is already there (DP).
+* LDX #ABORT
+* STX IP
+ LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
+*
+ NOP Here is a place to jump to special user
+ NOP initializations such as I/0 interrups
+ NOP
+*
+* For systems with TRACE:
+ LDX #00
+ STX ,U The hole above the parameter stack
+* STX TRLIM clear trace mode
+ STX <TRLIM clear trace mode (both bytes)
+ LDX #0
+* STX BRKPT clear breakpoint address
+ STX <BRKPT clear breakpoint address
+* JMP RPSTOR+2 start the virtual machine running !
+ LBSR RPSTOR+NATWID start the virtual machine running !
+ LEAX WENT,PCR ; But we must also give RP! someplace to return.
+ STX ,S ; This rail might get walked on by (DO).
+ LBRA NEXT
+* RP! sets up the return stack pointer, then Y references abort.
+*
+* Here is the stuff that gets copied to ram :
+* (not * at address $140:)
+* at an appropriate address:
+*
+* RAM FDB $3000,$3000,0,0
+* RAM FDB BUFBAS,BUFBAS,0,0 ; ... except the direct page has moved.
+* These initialization values for USE and PREV were here to help pack the code.
+* They don't belong here unless we move the USER table
+* back below the writable dictionary,
+* *and* move these USER variables to the end of the direct page --
+* *or* let these definitions exist in the USER table.
+RAM EQU *
+
+* ======>> (152) <<
+* ( --- ) P
+* Makes FORTH the current interpretation vocabulary.
+* In order to make this ROMmable, this entry is set up as the tail-end,
+* and copied to RAM in the start-up code.
+* We want a more elegant solution to this, too. Greedy, maybe.
+ FCB $C5 immediate
+ FCC 'FORT' ; 'FORTH'
+ FCB $C8
+ FDB NOOP-7 ; Note that this does not link to COLD!
+RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
+ FDB 0
+ FCC "Copyright 1979 Forth Interest Group, David Lion,"
+ FCB $0D
+ FCC "Parts Copyright 2019 Joel Matthew Rees"
+ FCB $0D
+ FCB $84
+ FCC 'TAS' ; 'TASK'
+ FCB $CB
+ FDB FORTH-8
+RTASK FDB DOCOL,SEMIS
+ERAM EQU *
+ERAMSZ EQU *-RAM ; So we can get a look at it.
+ PAGE
+*
+* ######>> screen 57 <<
+* ======>> 158 <<
+* ( n0 --- d0 )
+* Sign extend n0 to a double integer.
+ FCB $84
+ FCC 'S->' ; 'S->D'
+ FCB $C4
+ FDB COLD-7 ; Note that this does not link to FORTH (RFORTH)!
+STOD FDB DOCOL,DUP,ZLESS,MINUS
+ FDB SEMIS
+
+
+*
+* ======>> 159 <<
+* ( multiplier multiplicand --- product )
+* Signed word multiply.
+ FCB $81 ; *
+ FCB $AA
+ FDB STOD-7
+STAR FDB *+NATWID
+ LBSR USTAR+NATWID ; or [USTAR,PCR]?
+ LEAU NATWID,U ; Drop high word.
+ RTS
+* JSR USTARS
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP NEXT
+*
+* ======>> 160 <<
+* ( dividend divisor --- remainder quotient )
+* M/ in word-only form, i. e., signed division of 2nd word by top word,
+* yielding signed word quotient and remainder.
+* Except *BUG* it isn't signed.
+ FCB $84
+ FCC '/MO' ; '/MOD'
+ FCB $C4
+ FDB STAR-4
+SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
+ FDB SEMIS
+*
+* ======>> 161 <<
+* ( dividend divisor --- quotient )
+* Signed word divide without remainder.
+* Except *BUG* it isn't signed.
+ FCB $81 ; /
+ FCB $AF
+ FDB SLMOD-7
+SLASH FDB DOCOL,SLMOD,SWAP,DROP
+ FDB SEMIS
+*
+* ======>> 162 <<
+* ( dividend divisor --- remainder )
+* Remainder function, result takes sign of dividend.
+ FCB $83
+ FCC 'MO' ; 'MOD'
+ FCB $C4
+ FDB SLASH-4
+MOD FDB DOCOL,SLMOD,DROP
+ FDB SEMIS
+*
+* ======>> 163 <<
+* ( multiplier multiplicand divisor --- remainder quotient )
+* Signed precise division of product:
+* multiply 2nd and 3rd words on stack
+* and divide the 31-bit product by the top word,
+* leaving both quotient and remainder.
+* Remainder takes sign of product.
+* Guaranteed not to lose significant bits in 16 bit integer math.
+ FCB $85
+ FCC '*/MO' ; '*/MOD'
+ FCB $C4
+ FDB MOD-6
+SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
+ FDB SEMIS
+*
+* ======>> 164 <<
+* ( multiplier multiplicand divisor --- quotient )
+* */MOD without remainder.
+ FCB $82
+ FCC '*' ; '*/'
+ FCB $AF
+ FDB SSMOD-8
+SSLASH FDB DOCOL,SSMOD,SWAP,DROP
+ FDB SEMIS
+*
+* ======>> 165 <<
+* ( ud1 u1 --- u2 ud2 )
+* U/ with an (unsigned) double quotient.
+* Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
+* if you are prepared to deal with the extra 16 bits of result.
+ FCB $85
+ FCC 'M/MO' ; 'M/MOD'
+ FCB $C4
+ FDB SSLASH-5
+MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
+ FDB FROMR,SWAP,TOR,USLASH,FROMR
+ FDB SEMIS
+*
+* ======>> 166 <<
+* ( n>=0 --- n )
+* ( n<0 --- -n )
+* Convert the top of stack to its absolute value.
+ FCB $83
+ FCC 'AB' ; 'ABS'
+ FCB $D3
+ FDB MSMOD-8
+ABS FDB DOCOL,DUP,ZLESS,ZBRAN
+ FDB ABS2-*-NATWID
+ FDB MINUS
+ABS2 FDB SEMIS
+*
+* ======>> 167 <<
+* ( d>=0 --- d )
+* ( d<0 --- -d )
+* Convert the top double to its absolute value.
+ FCB $84
+ FCC 'DAB' ; 'DABS'
+ FCB $D3
+ FDB ABS-6
+DABS FDB DOCOL,DUP,ZLESS,ZBRAN
+ FDB DABS2-*-NATWID
+ FDB DMINUS
+DABS2 FDB SEMIS
+*
+* ######>> screen 58 <<
+* Disc primitives :
+* ======>> 168 <<
+* ( --- vadr )
+* Least Recently Used buffer.
+* Really should be with FIRST and LIMIT in the per-task table.
+ FCB $83
+ FCC 'US' ; 'USE'
+ FCB $C5
+ FDB DABS-7
+USE FDB DOCON
+ FDB XUSE
+* ======>> 169 <<
+* ( --- vadr )
+* Most Recently Used buffer.
+* Really should be with FIRST and LIMIT in the per-task table.
+ FCB $84
+ FCC 'PRE' ; 'PREV'
+ FCB $D6
+ FDB USE-6
+PREV FDB DOCON
+ FDB XPREV
+* ======>> 170 <<
+* ( buffer1 --- buffer2 f )
+* Bump to next buffer,
+* flag false if result is PREVious buffer,
+* otherwise flag true.
+* Used in the LRU allocation routines.
+ FCB $84
+ FCC '+BU' ; '+BUF'
+ FCB $C6
+ FDB PREV-7
+* PBUF FDB DOCOL,LIT8
+* FCB $84 ; This was a hard-wiring bug.
+PBUF FDB DOCOL,BBUF,BCTL,PLUS ; Size of the buffer record.
+* FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
+ FDB PLUS,DUP,LIMIT,LESS,ZEQU,OVER,FIRST,LESS,OR,ZBRAN
+ FDB PBUF2-*-NATWID ; Use defensive programming.
+ FDB DROP,FIRST
+PBUF2 FDB DUP,PREV,AT,SUB
+ FDB SEMIS
+*
+* ======>> 171 <<
+* ( --- f )
+* Flag to mark a buffer dirty, in need of being written out.
+* This flag limits the max number of sectors in a disk to ((256^NATWID)/2)-1.
+* It also hard-codes an implicit test which is used elsewhere.
+ FCB $8A
+ FCC 'UPDATE-BI' ; 'UPDATE-BIT'
+ FCB $D4
+ FDB PBUF-7
+UPDBIT FDB DOCON
+ FDB $8000
+*
+* ( --- )
+* Mark PREVious buffer dirty, in need of being written out.
+ FCB $86
+ FCC 'UPDAT' ; 'UPDATE'
+ FCB $C5
+ FDB UPDBIT-13
+* UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
+UPDATE FDB DOCOL,PREV,AT,AT,UPDBIT,OR,PREV,AT,STORE
+ FDB SEMIS
+*
+* ======>> 172 <<
+* ( adr --- )
+* Mark the buffer addressed as empty.
+* Have to add code to avoid block 0 appearing to be in a buffer from COLD.
+* Usually, there is no sector 0 (?), but the RAM buffers are too simple.
+* Note that without this block number being made illegal,
+* about 8 binaryMegabytes (256 bytes/block) of disk can be addressed total.
+* With this block number made illegal, the max is 1 block less,
+* still about 8 biMeg.
+ FCB $8B
+ FCC 'KILL-BUFFE' ; 'KILL-BUFFER'
+ FCB $D2
+ FDB UPDATE-9
+KILBUF FDB *+NATWID ; DOCOL,UPDBIT,ONE,SUB,SWAP,STORE
+ PULU X
+ LDD UPDBIT+NATWID,PCR
+ SUBD #1
+ STD ,X
+* LBSR DBGREG
+ RTS
+*
+* ( --- )
+* Mark all buffers empty.
+ FCB $8C
+ FCC 'KILL-BUFFER' ; 'KILL-BUFFERS'
+ FCB $D3
+ FDB KILBUF-14
+KLBFS FDB *+NATWID
+ LDD #4
+ PSHU D
+ LDD FIRST+NATWID,PCR
+* INC <TRACEM
+* LBSR DBGREG
+ PSHU D ; DUP
+KLBFSL PSHU D
+ BSR KILBUF+NATWID
+ LDD ,U
+* LBSR DBGREG
+ ADDD BBUF+NATWID,PCR
+ ADDD BCTL+NATWID,PCR
+ STD ,U
+* LBSR DBGREG
+ DEC NATWID+1,U
+ BNE KLBFSL
+* LBSR DBGREG
+ LEAU NATWID*2,U
+* DEC <TRACEM
+ RTS
+*
+* ( --- )
+* Erase and mark all buffers empty.
+* Standard method of discarding changes.
+ FCB $8D
+ FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
+ FCB $D3
+ FDB KLBFS-15
+MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
+* FDB FIRST,DUP,KILBUF,PBUF,DROP,DUP,KILBUF
+* FDB PBUF,DROP,DUP,KILBUF,PBUF,DROP,KILBUF
+ FDB KLBFS
+ FDB SEMIS
+*
+* ======>> 173 <<
+* ( --- )
+* Clear the current offset to the block numbers in the drive interface.
+* The drives need to be re-architected.
+* Would be cool to have RAM and ROM drives supported
+* in addition to regular physical persistent store.
+ FCB $83
+ FCC 'DR' ; 'DR0'
+ FCB $B0
+ FDB MTBUF-16
+DRZERO FDB DOCOL,ZERO,OFSET,STORE
+ FDB SEMIS
+*
+* ======>> 174 <<== system dependant word
+* ( --- )
+* Set the current offset in the drive interface to reference the second drive.
+* The hard-coded number in there needs to be in a table.
+ FCB $83
+ FCC 'DR' ; 'DR1'
+ FCB $B1
+ FDB DRZERO-6
+DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
+; **** hard-codes the size of the disc !!!!
+ FDB SEMIS
+*
+* ######>> screen 59 <<
+* ======>> 175 <<
+* ( n --- buffer )
+* Get a free buffer,
+* assign it to block n,
+* return buffer address.
+* Will free a buffer by writing it, if necessary.
+* Does not actually read the block.
+* A bug in the fig LRU algorithm, which I have not fixed,
+* gives the PREVious buffer if USE gets set to PREVious.
+* (The bug is that USE sometimes gets set to PREVious.)
+* This bug sometimes causes sector moves to become sector fills.
+ FCB $86
+ FCC 'BUFFE' ; 'BUFFER'
+ FCB $D2
+ FDB DRONE-6
+BUFFER FDB DOCOL,USE,AT,DUP,TOR
+BUFFR2 FDB PBUF,ZBRAN
+ FDB BUFFR2-*-NATWID
+ FDB USE,STORE,R,AT,ZLESS
+ FDB ZBRAN
+ FDB BUFFR3-*-NATWID
+* FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
+ FDB R,NATP,R,AT,UPDBIT,LNOT,AND,ZERO,RW
+* BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
+BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
+ FDB SEMIS
+*
+* ######>> screen 60 <<
+* ======>> 176 <<
+* ( n --- buffer )
+* Get BUFFER containing block n, relative to OFFSET.
+* If block n is not in a buffer, bring it in.
+* Returns buffer address.
+ FCB $85
+ FCC 'BLOC' ; 'BLOCK'
+ FCB $CB
+ FDB BUFFER-9
+BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
+ FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
+ FDB BLOCK5-*-NATWID
+BLOCK3 FDB PBUF,ZEQU,ZBRAN
+ FDB BLOCK4-*-NATWID
+* FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
+ FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
+BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
+ FDB BLOCK3-*-NATWID
+ FDB DUP,PREV,STORE
+* BLOCK5 FDB FROMR,DROP,TWOP
+BLOCK5 FDB FROMR,DROP,NATP
+ FDB SEMIS
+*
+* ######>> screen 61 <<
+* ======>> 177 <<
+* ( line screen --- buffer C/L)
+* Bring in the sector containing the specified line of the specified screen.
+* Returns the buffer address and the width of the screen.
+* Screen number is relative to OFFSET.
+* The line number may be beyond screen 4,
+* (LINE) will get the appropriate screen.
+ FCB $86
+ FCC '(LINE' ; '(LINE)'
+ FCB $A9
+ FDB BLOCK-8
+PLINE FDB DOCOL,TOR,LIT8
+ FCB $40
+ FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
+ FCB $40
+ FDB SEMIS
+*
+* ======>> 178 <<
+* ( line screen --- )
+* Print the line of the screen as found by (LINE), suppress trailing BLANKS.
+ FCB $85
+ FCC '.LIN' ; '.LINE'
+ FCB $C5
+ FDB PLINE-9
+DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
+ FDB SEMIS
+*
+* ======>> 179 <<
+* ( n --- )
+* If WARNING is 0, print "MESSAGE #n";
+* otherwise, print line n relative to screen 4,
+* the line number may be negative.
+* Uses .LINE, but counter-adjusts to be relative to the real drive 0.
+ FCB $87
+ FCC 'MESSAG' ; 'MESSAGE'
+ FCB $C5
+ FDB DLINE-8
+MESS FDB DOCOL,WARN,AT,ZBRAN
+ FDB MESS3-*-NATWID
+ FDB DDUP,ZBRAN
+ FDB MESS3-*-NATWID
+ FDB LIT8
+ FCB 4
+ FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
+ FDB MESS4-*-NATWID
+MESS3 FDB PDOTQ
+ FCB 6
+ FCC 'err # ' ; 'err # '
+ FDB DOT
+MESS4 FDB SEMIS
+*
+* ======>> 180 <<
+* ( n --- )
+* Begin interpretation of screen (block) n.
+* See also ARROW, SEMIS, and NULL.
+ FCB $84
+ FCC 'LOA' ; 'LOAD' : input:scr #
+ FCB $C4
+ FDB MESS-10
+LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
+ FDB BSCR,STAR,BLK,STORE
+ FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
+ FDB SEMIS
+*
+* ======>> 181 <<
+* ( --- ) P
+* Continue interpreting source code on the next screen.
+ FCB $C3
+ FCC '--' ; '-->'
+ FCB $BE
+ FDB LOAD-7
+ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
+ FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
+ FDB SEMIS
+ PAGE
+*
+*
+* ######>> screen 63 <<
+* The next 4 subroutines are machine dependent, and are
+* called by words 13 through 16 in the dictionary.
+*
+* ======>> 182 << code for EMIT
+* ( --- ) No parameter stack effect.
+* Interfaces directly with ROM. Expects output character in D (therefore, B).
+* Output using rom CHROUT: redirectable to a printer on Coco.
+* Outputs the character on stack (low byte of 1 bit word/cell).
+PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.)
+ TFR B,A ; Coco ROM wants it in A.
+ CLRB
+ TFR B,DP ; Give the ROM its direct page.
+ JSR [$A002] ; Output the character in A.
+ PULS Y,U,DP,PC
+* PEMIT STB N save B
+* STX N+1 save X
+* LDB ACIAC
+* BITB #2 check ready bit
+* BEQ PEMIT+4 if not ready for more data
+* STA ACIAD
+* LDX UP
+* STB IOSTAT-UORIG,X
+* LDB N recover B & X
+* LDX N+1
+* RTS only A register may change
+* PEMIT JMP $E1D1 for MIKBUG
+* PEMIT FCB $3F,$11,$39 for PROTO
+* PEMIT JMP $D286 for Smoke Signal DOS
+*
+* ======>> 183 << code for KEY
+* ( --- ) No parameter stack effect.
+* Returns character or break flag in D, since this interfaces with Coco ROM.
+* Wait for key from POLCAT on Coco.
+* Returns the character code for the key pressed.
+PKEY PSHS Y,U,DP ; Must save everything important for this one.
+ LDA #$CF ; a cursor of sorts
+ CLRB
+ TFR B,DP
+ SETDP 0
+ LDX <$88 ; location
+ LDB ,X ; save glyph
+ STA ,X
+PKEYLP JSR [$A000]
+* STA $41A ; DBG!
+ BEQ PKEYLP
+* STD $418 ; DBG!
+ STB ,X ; restore
+PKEYR CLRB ; for the break flag, shares code with PQTER
+ CMPA #3 ; break key
+ BNE PKEYGT
+ COMB ; for the break flag
+PKEYGT EXG A,B ; Leave it in D for return.
+ PULS Y,U,DP,PC ; Shares exit with PQTER
+ SETDP IUPDP
+* PKEY STB N
+* STX N+1
+* LDB ACIAC
+* ASRB ;
+* BCC PKEY+4 no incoming data yet
+* LDA ACIAD
+* ANDA #$7F strip parity bit
+* LDX UP
+* STB IOSTAT+1-UORIG,X
+* LDB N
+* LDX N+1
+* RTS
+* PKEY JMP $E1AC for MIKBUG
+* PKEY FCB $3F,$14,$39 for PROTO
+* PKEY JMP $D289 for Smoke Signal DOS
+*
+* ######>> screen 64 <<
+* ======>> 184 << code for ?TERMINAL
+* ( --- f ) Should change this to no stack effect.
+* check break key using POLCAT
+* Returns a flag to tell whether the break key was pressed or not.
+PQTER PSHS Y,U,DP
+ CLRB
+ TFR B,DP
+ JSR [$A000] ; Look but don't wait.
+ BRA PKEYR
+* PQTER LDA ACIAC Test for 'break' condition
+* ANDA #$11 mask framing error bit and
+* input buffer full
+* BEQ PQTER2
+* LDA ACIAD clear input buffer
+* LDA #01
+* PQTER2 RTS
+
+
+ PAGE
+*
+* ======>> 185 << code for CR
+* ( --- ) No stack effect.
+* Interfaces directly with ROM.
+* For Coco just output a CR.
+* Also subject to redirection in Coco BASIC ROM.
+PCR LDB #$0D
+ BRA PEMIT ; Just steal the code.
+* PCR LDA #$D carriage return
+* BSR PEMIT
+* LDA #$A line feed
+* BSR PEMIT
+* LDA #$7F rubout
+* LDX UP
+* LDB XDELAY+1-UORIG,X
+* PCR2 DECB ;
+* BMI PQTER2 return if minus
+* PSHS B ; save counter
+* BSR PEMIT print RUBOUTs to delay.....
+* PULS B ;
+* BRA PCR2 repeat
+
+
+ PAGE
+*
+* ######>> screen 66 <<
+* ======>> 187 <<
+* ( ??? )
+* Query the disk, I suppose.
+* Not sure what the model had in mind for this stub.
+ FCB $85
+ FCC '?DIS' ; '?DISC'
+ FCB $C3
+ FDB ARROW-6
+QDISC FDB *+NATWID
+ JMP NEXT
+*
+* ######>> screen 67 <<
+* ======>> 189 <<
+* ( ??? )
+* Write one block of data to disk.
+* Parameters unspecified in model. Stub in model.
+ FCB $8B
+ FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
+ FCB $C5
+ FDB QDISC-8
+BWRITE FDB *+NATWID
+ JMP NEXT
+*
+* ######>> screen 68 <<
+* ======>> 190 <<
+* ( ??? )
+* Read one block of data from disk.
+* Parameters unspecified in model. Stub in model.
+ FCB $8A
+ FCC 'BLOCK-REA' ; 'BLOCK-READ'
+ FCB $C4
+ FDB BWRITE-14
+BREAD FDB *+NATWID
+ JMP NEXT
+*
+*The next 3 words are written to create a substitute for disc
+* mass memory,located between MASSLO & MASSHI in ram --
+* ($3210 and $3fff in the 6800 model).
+* ======>> 190.1 <<
+ FCB $82
+ FCC 'L' ; 'LO'
+ FCB $CF
+ FDB BREAD-13
+LO FDB DOCON
+ FDB MEMEND a system dependent equate at front
+*
+* ======>> 190.2 <<
+ FCB $82
+ FCC 'H' ; 'HI'
+ FCB $C9
+ FDB LO-5
+HI FDB DOCON
+ FDB MEMTOP ( $3FFF or $7FFF in this version )
+*
+* ######>> screen 69 <<
+* ======>> 191 <<
+* ( buffer sector f --- )
+* Read or Write the specified (absolute -- ignores OFFSET) sector
+* from or to the specified buffer.
+* A zero flag specifies write,
+* non-zero specifies read.
+* Sector is an unsigned integer,
+* buffer is the buffer's address.
+* Will need to use the CoCo ROM disk routines.
+* For now, provides a virtual disk in RAM.
+ FCB $83
+ FCC 'R/' ; 'R/W'
+ FCB $D7
+ FDB HI-5
+RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
+ FDB RW2-*-NATWID
+ FDB PDOTQ
+ FCB 8
+ FCC ' Range ?' ; ' Range ?'
+ FDB QUIT
+RW2 FDB FROMR,ZBRAN
+ FDB RW3-*-NATWID
+ FDB SWAP
+RW3 FDB BBUF,CMOVE
+ FDB SEMIS
+*
+* From BIF-6809:
+* RW PSHS Y,U,DP
+* LDY $C006 control table
+* LDX #DROFFS+7 ; This is BIF's table of drive sizes.
+* LDD 2,U
+* RWD SUBD ,X++ sectors
+* BHS RWD
+* BVC RWR table end?
+* LDD #6
+* PSHU D
+* JMP ERROR
+* RWR ADDD ,--X back one
+* PSHS X
+* PSHU D
+* LDD #18 sectors/track
+* PSHU D
+* DOCOL
+* FDB SLAMOD
+* FDB XMACH
+* PULU D
+* STB 2,Y track
+* PULU D
+* INCB
+* STB 3,Y sector
+* PULS D table entry
+* SUBD #DROFFS+7
+* ASRB drive #
+* STB 1,Y
+* LDD 4,U buffer
+* STD 4,Y
+* LDB #2 coco READ
+* LDX ,U 0?
+* BNE *+3
+* INCB coco WRITE
+* STB ,Y op code
+* CLRA
+* TFR A,DP
+* JSR [$C004] ROM handles timeout
+* PULS Y,U,DP if IRQ enabled
+* LEAU 6,U
+* LDX $C006
+* LDB 6,X coco status
+* BEQ RWE
+* LDX <UP
+* LDD #0 no disc
+* STD UWARN,X
+* LDD #8
+* PSHU D
+* JMP ERROR
+* RWE NEXT
+*
+* ######>> screen 72 <<
+* ======>> 192 <<
+* ( --- ) compiling P
+* ( --- adr ) interpreting
+* { ' name } input
+* Parse a symbol name from input and search the dictionary for it, per -FIND;
+* compile the address as a literal if compiling,
+* otherwise just push it.
+ FCB $C1 immediate
+ FCB $A7 ' ( tick )
+ FDB RW-6
+TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
+ FDB SEMIS
+*
+* ======>> 193 <<
+* ( --- ) { FORGET name } input
+* Parse out name of definition to FORGET to, -DFIND it,
+* then lop it and everything that follows out of the dictionary.
+* In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
+ FCB $86
+ FCC 'FORGE' ; 'FORGET'
+ FCB $D4
+ FDB TICK-4
+FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
+ FCB $18
+ FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT8
+ FCB $15
+ FDB QERR,DUP,ZERO,PORIG,GREAT,LIT8
+ FCB $15
+ FDB QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
+ FDB SEMIS
+*
+* ######>> screen 73 <<
+* ======>> 194 <<
+* ( adr --- ) C
+* Calculate a back reference from HERE and compile it.
+ FCB $84
+ FCC 'BAC' ; 'BACK'
+ FCB $CB
+ FDB FORGET-9
+* BACK FDB DOCOL,HERE,SUB,COMMA
+BACK FDB DOCOL,HERE,NATP,SUB,COMMA
+ FDB SEMIS
+*
+* ======>> 195 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop test UNTIL
+* typical use: BEGIN code-loop AGAIN
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* ( --- adr n ) compile time P,C
+* Push HERE for BACK reference for general (non-counting) loops,
+* with BEGIN construct flag.
+* A better flag: $4245 (ASCII for 'BE').
+ FCB $C5
+ FCC 'BEGI' ; 'BEGIN'
+ FCB $CE
+ FDB BACK-7
+BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
+ FDB SEMIS
+*
+* ======>> 196 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ENDIF is just a sort of intersection piece,
+* marking where execution resumes after both branches.
+* ( adr n --- ) compile time
+* Check the mark and resolve the IF.
+* A better flag: $4846 (ASCII for 'IF').
+ FCB $C5
+ FCC 'ENDI' ; 'ENDIF'
+ FCB $C6
+ FDB BEGIN-8
+ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
+ FDB OVER,NATP,SUB,SWAP,STORE
+ FDB SEMIS
+*
+* ======>> 197 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ( adr n --- )
+* Alias for ENDIF .
+ FCB $C4
+ FCC 'THE' ; 'THEN'
+ FCB $CE
+ FDB ENDIF-8
+THEN FDB DOCOL,ENDIF
+ FDB SEMIS
+*
+* ======>> 198 <<
+* ( limit index --- ) runtime
+* typical use: DO code-loop LOOP
+* typical use: DO code-loop increment +LOOP
+* Counted loop, index is initial value of index.
+* Will loop until index equals (positive going)
+* or passes (negative going) limit.
+* ( --- adr n ) compile time P,C
+* Compile (DO), push HERE for BACK reference,
+* and push DO control construct flag.
+* A better flag: $444F (ASCII for 'DO').
+ FCB $C2
+ FCC 'D' ; 'DO'
+ FCB $CF
+ FDB THEN-7
+DO FDB DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
+ FDB SEMIS
+*
+* ======>> 199 <<
+* ( --- ) runtime
+* typical use: DO code-loop LOOP
+* Increments the index by one and branches back to beginning of loop.
+* Will loop until index equals limit.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (LOOP), fill in BACK reference.
+* A better flag: $444F (ASCII for 'DO').
+ FCB $C4
+ FCC 'LOO' ; 'LOOP'
+ FCB $D0
+ FDB DO-5
+LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
+ FDB SEMIS
+*
+* ======>> 200 <<
+* ( n --- ) runtime
+* typical use: DO code-loop increment +LOOP
+* Increments the index by n and branches back to beginning of loop.
+* Will loop until index equals (positive going)
+* or passes (negative going) limit.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (+LOOP), fill in BACK reference.
+* A better flag: $444F (ASCII for 'DO').
+ FCB $C5
+ FCC '+LOO' ; '+LOOP'
+ FCB $D0
+ FDB LOOP-7
+PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
+ FDB SEMIS
+*
+* ======>> 201 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test UNTIL
+* Will loop until UNTIL tests true.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (0BRANCH), fill in BACK reference.
+* A better flag: $4245 (ASCII for 'BE').
+ FCB $C5
+ FCC 'UNTI' ; 'UNTIL' : ( same as END )
+ FCB $CC
+ FDB PLOOP-8
+UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
+ FDB SEMIS
+*
+* ######>> screen 74 <<
+* ======>> 202 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test END
+* ( adr n --- )
+* Alias for UNTIL .
+ FCB $C3
+ FCC 'EN' ; 'END'
+ FCB $C4
+ FDB UNTIL-8
+END FDB DOCOL,UNTIL
+ FDB SEMIS
+*
+* ======>> 203 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop AGAIN
+* Will loop forever
+* (or until something uses R> DROP to force the current definition to die,
+* or perhaps ABORT or ERROR or some such other drastic means stops things).
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (0BRANCH), fill in BACK reference.
+* A better flag: $4245 (ASCII for 'BE').
+ FCB $C5
+ FCC 'AGAI' ; 'AGAIN'
+ FCB $CE
+ FDB END-6
+AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
+ FDB SEMIS
+*
+* ======>> 204 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* Will loop until WHILE tests false, skipping code-true on end.
+* REPEAT marks where execution resumes after the WHILE find a false flag.
+* ( aadr1 n1 adr2 n2 --- ) compile time P,C
+* Check the marks for WHILE and BEGIN,
+* compile BRANCH and BACK fill adr1 reference,
+* FILL-IN 0BRANCH reference at adr2.
+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+ FCB $C6
+ FCC 'REPEA' ; 'REPEAT'
+ FCB $D4
+ FDB AGAIN-8
+REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
+ FDB TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
+ FDB SEMIS
+*
+* ======>> 205 <<
+* ( n --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* Will pass execution to the true part on a true flag
+* and to the false part on a false flag.
+* ( --- adr n ) compile time P,C
+* Compile a 0BRANCH and dummy offset
+* and push IF reference to fill in and
+* IF control construct flag.
+* A better flag: $4946 (ASCII for 'IF').
+ FCB $C2
+ FCC 'I' ; 'IF'
+ FCB $C6
+ FDB REPEAT-9
+IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
+ FDB SEMIS
+*
+* ======>> 206 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ELSE is just a sort of intersection piece,
+* marking where execution resumes on a false branch.
+* ( adr1 n --- adr2 n ) compile time P,C
+* Check the marks,
+* compile BRANCH with dummy offset,
+* resolve IF reference,
+* and leave reference to BRANCH for ELSE.
+* A better flag: $4946 (ASCII for 'IF').
+ FCB $C4
+ FCC 'ELS' ; 'ELSE'
+ FCB $C5
+ FDB IF-5
+ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
+ FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
+ FDB SEMIS
+*
+* ======>> 207 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* Will loop until WHILE tests false, skipping code-true on end.
+* ( --- adr n ) compile time P,C
+* Compile 0BRANCH with dummy offset (using IF),
+* push WHILE reference.
+* BEGIN flag will sit underneath this.
+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+ FCB $C5
+ FCC 'WHIL' ; 'WHILE'
+ FCB $C5
+ FDB ELSE-7
+WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
+ FDB SEMIS
+*
+* ######>> screen 75 <<
+* ======>> 208 <<
+* ( count --- )
+* EMIT count spaces, for non-zero, non-negative counts.
+ FCB $86
+ FCC 'SPACE' ; 'SPACES'
+ FCB $D3
+ FDB WHILE-8
+SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
+ FDB SPACE3-*-NATWID
+ FDB ZERO,XDO
+SPACE2 FDB SPACE,XLOOP
+ FDB SPACE2-*-NATWID
+SPACE3 FDB SEMIS
+*
+* ======>> 209 <<
+* ( --- )
+* Initialize HLD for converting a double integer.
+* Stores the PAD address in HLD.
+ FCB $82
+ FCC '<' ; '<#'
+ FCB $A3
+ FDB SPACES-9
+BDIGS FDB DOCOL,PAD,HLD,STORE
+ FDB SEMIS
+*
+* ======>> 210 <<
+* ( d --- string length )
+* Terminate numeric conversion,
+* drop the number being converted,
+* leave the address of the conversion string and the length, ready for TYPE.
+ FCB $82
+ FCC '#' ; '#>'
+ FCB $BE
+ FDB BDIGS-5
+EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
+ FDB SEMIS
+*
+* ======>> 211 <<
+* ( n d --- d )
+* Put sign of n (as a flag) at the head of the conversion string.
+* Drop the sign flag.
+ FCB $84
+ FCC 'SIG' ; 'SIGN'
+ FCB $CE
+ FDB EDIGS-5
+SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
+ FDB SIGN2-*-NATWID
+ FDB LIT8
+ FCC "-"
+ FDB HOLD
+SIGN2 FDB SEMIS
+*
+* ======>> 212 <<
+* ( d --- d/base )
+* Generate next most significant digit in the conversion BASE,
+* putting the digit at the head of the conversion string.
+ FCB $81 #
+ FCB $A3
+ FDB SIGN-7
+DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
+ FCB 9
+ FDB OVER,LESS,ZBRAN
+ FDB DIG2-*-NATWID
+ FDB LIT8
+ FCB 7
+ FDB PLUS
+DIG2 FDB LIT8
+ FCC "0" ascii zero
+ FDB PLUS,HOLD
+ FDB SEMIS
+*
+* ======>> 213 <<
+* ( d --- dzero )
+* Convert d to a numeric string using # until the result is zero.
+* Leave the double result on the stack for #> to drop.
+ FCB $82
+ FCC '#' ; '#S'
+ FCB $D3
+ FDB DIG-4
+DIGS FDB DOCOL
+DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
+ FDB DIGS2-*-NATWID
+ FDB SEMIS
+*
+* ######>> screen 76 <<
+* ======>> 214 <<
+* ( n width --- )
+* Print n on the output device in the current conversion base,
+* with sign,
+* right aligned in a field at least width wide.
+ FCB $82
+ FCC '.' ; '.R'
+ FCB $D2
+ FDB DIGS-5
+DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
+ FDB SEMIS
+*
+* ======>> 215 <<
+* ( d width --- )
+* Print d on the output device in the current conversion base,
+* with sign,
+* right aligned in a field at least width wide.
+ FCB $83
+ FCC 'D.' ; 'D.R'
+ FCB $D2
+ FDB DOTR-5
+DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
+ FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
+ FDB SEMIS
+*
+* ======>> 216 <<
+* D. ( d --- )
+* Print d on the output device in the current conversion base,
+* with sign,
+* in free format with trailing space.
+ FCB $82
+ FCC 'D' ; 'D.'
+ FCB $AE
+ FDB DDOTR-6
+DDOT FDB DOCOL,ZERO,DDOTR,SPACE
+ FDB SEMIS
+*
+* ======>> 217 <<
+* ( n --- )
+* Print n on the output device in the current conversion base,
+* with sign,
+* in free format with trailing space.
+ FCB $81 .
+ FCB $AE
+ FDB DDOT-5
+DOT FDB DOCOL,STOD,DDOT
+ FDB SEMIS
+*
+* ======>> 218 <<
+* ( adr --- )
+* Print signed word at adr, per DOT.
+ FCB $81 ?
+ FCB $BF
+ FDB DOT-4
+QUEST FDB DOCOL,AT,DOT
+ FDB SEMIS
+*
+* ######>> screen 77 <<
+* ======>> 219 <<
+* ( n --- )
+* Print out screen n as a field of ASCII,
+* with line numbers in decimal.
+* Needs a console more than 70 characters wide.
+ FCB $84
+ FCC 'LIS' ; 'LIST'
+ FCB $D4
+ FDB QUEST-4
+LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
+ FCB 6
+ FCC "SCR # "
+ FDB DOT,LIT8
+ FCB $10
+ FDB ZERO,XDO
+LIST2 FDB CR,I,THREE
+ FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
+ FDB LIST2-*-NATWID
+ FDB CR
+ FDB SEMIS
+*
+* ======>> 220 <<
+* ( start end --- )
+* Print comment lines (line 0, and line 1 if C/L < 41) of screens
+* from start to end.
+* Needs a console more than 70 characters wide.
+ FCB $85
+ FCC 'INDE' ; 'INDEX'
+ FCB $D8
+ FDB LIST-7
+INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
+INDEX2 FDB CR,I,THREE
+ FDB DOTR,SPACE,ZERO,I,DLINE
+ FDB QTERM,ZBRAN
+ FDB INDEX3-*-NATWID
+ FDB LEAVE
+INDEX3 FDB XLOOP
+ FDB INDEX2-*-NATWID
+ FDB SEMIS
+*
+* ======>> 221 <<
+* ( n --- )
+* List a printer page full of screens.
+* Line and screen number are in current base.
+* Needs a console more than 70 characters wide.
+ FCB $85
+ FCC 'TRIA' ; 'TRIAD'
+ FCB $C4
+ FDB INDEX-8
+TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
+ FDB THREE,OVER,PLUS,SWAP,XDO
+TRIAD2 FDB CR,I
+ FDB LIST,QTERM,ZBRAN
+ FDB TRIAD3-*-NATWID
+ FDB LEAVE
+TRIAD3 FDB XLOOP
+ FDB TRIAD2-*-NATWID
+ FDB CR,LIT8
+ FCB $0F
+ FDB MESS,CR
+ FDB SEMIS
+*
+* ######>> screen 78 <<
+* ======>> 222 <<
+* ( --- )
+* Alphabetically list the definitions in the current vocabulary.
+* Expects to output to printer, not TRS80 Color Computer screen.
+ FCB $85
+ FCC 'VLIS' ; 'VLIST'
+ FCB $D4
+ FDB TRIAD-8
+VLIST FDB DOCOL,LIT8
+ FCB $80
+ FDB OUT,STORE,CONTXT,AT,AT
+VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
+ FCB 32
+ FDB SUB,GREAT,ZBRAN
+ FDB VLIST2-*-NATWID
+ FDB CR,ZERO,OUT,STORE
+VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
+ FDB DUP,ZEQU,QTERM,OR,ZBRAN
+ FDB VLIST1-*-NATWID
+ FDB DROP
+ FDB SEMIS
+*
+* Need some utility stuff that isn't in the fig FORTH:
+* ( c --- )
+* Emit dot if c is less than blank, else emit c
+ FCB $85
+ FCC 'BEMI' ; 'BEMIT'
+ FCB $D4 ; 'T'
+ FDB VLIST-8
+BEMIT FDB DOCOL
+ FDB DUP,BL,LESS,ZBRAN
+ FDB BEMITO-*-NATWID
+ FDB DROP,LIT8
+ FCB $2e ; '.'
+BEMITO FDB EMIT
+ FDB SEMIS
+*
+* ( n width --- )
+* Output n in hexadecimal field width.
+ FCB $83
+ FCC 'X.' ; 'X.R'
+ FCB $D2 ; 'R'
+ FDB BEMIT-8
+XDOTR FDB DOCOL
+ FDB BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
+ FDB SEMIS
+*
+* ( adr --- )
+* Dump a line of 4 bytes in memory, in hex and as characters.
+ FCB $85
+ FCC 'BLIN' ; 'BLINE'
+ FCB $C5 ; 'E'
+ FDB XDOTR-6
+BLINE FDB DOCOL
+ FDB DUP,LIT8
+ FCB 4
+ FDB PLUS,OVER,XDO
+BLINEX FDB I,CAT,THREE,XDOTR,XLOOP
+ FDB BLINEX-*-NATWID
+ FDB SPACE,SPACE
+ FDB DUP,LIT8
+ FCB 4
+ FDB PLUS,SWAP,XDO
+BLINEC FDB I,CAT,BEMIT,XLOOP
+ FDB BLINEC-*-NATWID
+ FDB SEMIS
+*
+* ( start end --- )
+* Dump 4 byte lines from start to end.
+ FCB $85
+ FCC 'BDUM' ; 'BDUMP'
+ FCB $D0 ; '5'
+ FDB BLINE-8
+BDUMP FDB DOCOL
+ FDB CR,XDO
+BDUMPL FDB I,LIT8
+ FCB 4
+ FDB XDOTR,LIT8
+ FCB $3A
+ FDB EMIT,SPACE
+ FDB I,BLINE,CR,LIT8
+ FCB 4
+ FDB XPLOOP
+ FDB BDUMPL-*-NATWID
+ FDB SEMIS
+*
+* ======>> XX <<
+* ( --- )
+* Mostly for place holding (fig Forth).
+ FCB $84
+ FCC 'NOO' ; 'NOOP'
+ FCB $D0
+ FDB BDUMP-8
+NOOP FDB *+NATWID
+ RTS
+* Without the RTS, would misalign the stack.
+* NOOP NEXT a useful no-op
+ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
+
+ PAGE
+* These things, up through the lable 'REND', are overwritten
+* at time of cold load and should have the same contents
+* as shown here:
+*
+* This can be moved whereever the bottom of the
+* user's dictionary is going to be put.
+*
+RBEG EQU *
+ FCB $C5 immediate
+ FCC 'FORT' ; 'FORTH'
+ FCB $C8
+ FDB NOOP-7
+FORTH FDB DODOES,DOVOC,$81A0,TASK-7
+ FDB 0
+*
+ FCC "Copyright 1979 Forth Interest Group, David Lion,"
+ FCB $0D
+ FCC "Parts Copyright 2019 Joel Matthew Rees"
+ FCB $0D
+*
+ FCB $84
+ FCC 'TAS' ; 'TASK'
+ FCB $CB
+ FDB FORTH-8
+TASK FDB DOCOL,SEMIS
+*
+REND EQU * ( first empty location in dictionary )
+RSIZE EQU *-RBEG ; So we can look at it.
+ PAGE
+
+ ORG RAMDSK
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " 0) Index page " ; 0
+ FCC " 1) empty line on line 1 of screen 0 block 0 " ; 1
+ FCC " 2) Title and copyright " ; 2
+ FCC " 3) empty line on line 3 of screen 0 block 0 " ; 3
+ FCC " 4) Error messages 1st screen " ; 4
+ FCC " 5) Error messages 2nd screen " ; 5
+ FCC " 6) empty line 3 screen 0 block 1 " ; 6
+ FCC " 7) empty line 4 " ; 7
+ FCC " 8) and line 1 of block 2 " ; 8
+ FCC " 9) line 2 of block 2 screen 0 is pretty much empty too " ; 9
+ FCC " 10) listen to this. Line three of block two is too " ; 10
+ FCC " 11) and so is line 4 4 4 4 4 4 4 4 4 4 b2s0 " ; 11
+ FCC " 12) screen zero block three first line " ; 12
+ FCC " 13) second line fourth block (block three) screen 0 " ; 13
+ FCC " 14) block three screen zero line 3 3 3 3 3 3 3 3 3 " ; 14
+ FCC " 15) fourth line block three screen 0 0 0 0 0 0 0 0 0 0 " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " test 10 b0s1 aaaa " ; 0
+ FCC " test 11 b0s1 ee ee ee ee " ; 1
+ FCC " test 12 b0s1 oo oo oo oo oo " ; 2
+ FCC " test 13 b0s1 eh ehe he eh eh " ; 3
+ FCC " ( block 1 ) b1s1 oh ohoo oh oh oh " ; 4
+ FCC " 15 test b1s1 " ; 5
+ FCC " 16 test b1s1 " ; 6
+ FCC " 17 test b1s1 " ; 7
+ FCC " 18 test b2s1 " ; 8
+ FCC " 19 test b2s1 " ; 9
+ FCC " 1A test b2s1 " ; 10
+ FCC " 1B test b2ws1 " ; 11
+ FCC " 1C test b3s1 " ; 12
+ FCC " 1D test b3s1 " ; 13
+ FCC " 1e this completes our second screen b3s1 " ; 14
+ FCC " 1F test b3s1 " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " " ; 0
+ FCC " fig Forth High Level Model Code " ; 1
+ FCC " " ; 2
+ FCC " Copyright 2018 Joel Matthew Rees " ; 3
+ FCC " ( block 2 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " " ; 0
+ FCC " " ; 1
+ FCC " " ; 2
+ FCC " " ; 3
+ FCC " ( block 3 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " " ; 0
+ FCC " " ; 1
+ FCC " " ; 2
+ FCC " " ; 3
+ FCC " ( block 4 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " ( ERROR MESSAGES ) " ; 0
+ FCC " DATA STACK UNDERFLOW " ; 1
+ FCC " DICTIONARY FULL " ; 2
+ FCC " ADDRESS RESOLUTION ERROR " ; 3
+ FCC " HIDES DEFINITION IN " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " more test data 2 3 4 5 6 " ; 0
+ FCC "0123456789012345678901234567890123456789012345678901234567890123" ; 1
+ FCC "Test data for the RAM disc emulator buffers. " ; 2
+ FCC " " ; 3
+ FCC " ( block 6 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " end" ; 15
+RAMDND EQU *
+
+
+ PAGE
+ OPT L
+ END
+++ /dev/null
- OPT PRT
-
-* fig-FORTH FOR 6800
-* ASSEMBLY SOURCE LISTING
-
-* RELEASE 1
-* MAY 1979
-* WITH COMPILER SECURITY
-* AND VARIABLE LENGTH NAMES
-
-* This public domain publication is provided
-* through the courtesy of:
-* FORTH
-* INTEREST
-* GROUP
-* fig
-
-* P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
-* Further distribution must include this notice.
- PAGE
- NAM Copyright:FORTH Interest Group
- OPT NOG,PAG
-* filename FTH7.21
-* === FORTH-6800 06-06-79 21:OO
-
-
-* 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.
-
-* === by Dave Lion,
-* === with help from
-* === Bob Smith,
-* === LaFarr Stuart,
-* === The Forth Interest Group
-* === PO Box 1105
-* === San Carlos, CA 94070
-* === and
-* === Unbounded Computing
-* === 1134-K Aster Ave.
-* === Sunnyvale, CA 94086
-*
-* This version was developed on an AMI EVK 300 PROTO
-* system using an ACIA for the I/O. 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
-* tested using a real disc.
-*
-* Addresses in this implementation reflect the fact that,
-* on the development system, it was convenient to
-* write-protect memory at hex 1000, and leave the first
-* 4K bytes write-enabled. As a consequence, code from
-* location $1000 to lable ZZZZ could be put in ROM.
-* Minor deviations from the model were made in the
-* initialization and words ?STACK and FORGET
-* in order to do this.
-*
-
-
-*
-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-
-* protected segments can write protect FORTH )
-*
-* addr. contents pointer init by
-* **** ******************************* ******* ******
-* 3FFF HI
-* substitute for disc mass memory
-* 3210 LO,MEMEND
-* 320F
-* 4 buffer sectors of VIRTUAL MEMORY
-* 3000 FIRST
-* >>>>>> memory from here up must be RAM <<<<<<
-*
-* 27FF
-* 6k of romable "FORTH" <== IP ABORT
-* <== W
-* the VIRTUAL FORTH MACHINE
-*
-* 1004 <<< WARM START ENTRY >>>
-* 1000 <<< COLD START ENTRY >>>
-*
-* >>>>>> memory from here down must be RAM <<<<<<
-* FFE RETURN STACK base <== RP RINIT
-*
-* FB4
-* INPUT LINE BUFFER
-* holds up to 132 characters
-* and is scanned upward by IN
-* starting at TIB
-* F30 <== IN TIB
-* F2F DATA STACK <== SP SP0,SINIT
-* | grows downward from F2F
-* v
-* - -
-* |
-* I DICTIONARY grows upward
-*
-* 183 end of ram-dictionary. <== DP DPINIT
-* "TASK"
-*
-* 150 "FORTH" ( a word ) <=, <== CONTEXT
-* `==== CURRENT
-* 148 start of ram-dictionary.
-*
-* 100 user #l table of variables <= UP DPINIT
-* F0 registers & pointers for the virtual machine
-* scratch area used by various words
-* E0 lowest address used by FORTH
-*
-* 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
-*
-* when A and B hold one 16 bit FORTH data word,
-* A contains the high byte, B, the low byte.
-***
-
-
-
-
- ORG $E0 variables
-
-
-N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
-* SP@,SWAP,DOES>,COLD
-
-
-* These locations are used by the TRACE routine :
-
-TRLIM RMB 1 the count for tracing without user intervention
-TRACEM RMB 1 non-zero = trace mode
-BRKPT RMB 2 the breakpoint address at which
-* the program will go into trace mode
-VECT RMB 2 vector to machine code
-* (only needed if the TRACE routine is resident)
-
-
-* Registers used by the FORTH virtual machine:
-* Starting at $OOFO:
-
-
-W RMB 2 the instruction register points to 6800 code
-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
-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
-XVOCL RMB 2 vocabulary linking
-XBLK RMB 2 disc block being accessed
-XIN RMB 2 scan pointer into the block
-XOUT RMB 2 cursor position
-XSCR RMB 2 disc screen being accessed ( O=terminal )
-XOFSET RMB 2 disc sector offset for multi-disc
-XCONT RMB 2 last word in primary search vocabulary
-XCURR RMB 2 last word in extensible vocabulary
-XSTATE RMB 2 flag for 'interpret' or 'compile' modes
-XBASE RMB 2 number base for I/O numeric conversion
-XDPL RMB 2 decimal point place
-XFLD RMB 2
-XCSP RMB 2 current stack position, for compile checks
-XRNUM RMB 2
-XHLD RMB 2
-XDELAY RMB 2 carriage return delay count
-XCOLUM RMB 2 carriage width
-IOSTAT RMB 2 last acia status from write/read
- RMB 2 ( 4 spares! )
- RMB 2
- RMB 2
- RMB 2
-
-
-
-
-*
-*
-* end of user table, start of common system variables
-*
-*
-*
-XUSE RMB 2
-XPREV RMB 2
- RMB 4 ( spares )
-
- PAGE
-* 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
-
-* ######>> screen 3 <<
-*
-***************************
-** C O L D E N T R Y **
-***************************
-ORIG NOP
- JMP CENT
-***************************
-** W A R M E N T R Y **
-***************************
- NOP
- JMP WENT warm-start code, keeps current dictionary intact
-
-*
-******* startup parmeters **************************
-*
- FDB $6800,0000 cpu & revision
- FDB 0 topmost word in FORTH vocabulary
-BACKSP FDB $7F backspace character for editing
-UPINIT FDB UORIG initial user area
-SINIT FDB ORIG-$D0 initial top of data stack
-RINIT FDB ORIG-2 initial top of return stack
- FDB ORIG-$D0 terminal input buffer
- 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
-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
- BRA NEXT
-GETX LDA 0,X 18 cycles until 'NEXT'
- LDB 1,X
-PUSHBA PSHS B ; 8 cycles until 'NEXT'
- PSHS A ;
-
-
-
-*
-* "NEXT" takes 38 cycles if TRACE is removed,
-*
-* and 95 cycles if 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
-* =
-* The next instruction could be patched to JMP TRACE =
-* if a TRACE routine is available: =
-* =
- JMP 0,X
- NOP
-* JMP TRACE ( an alternate for the above )
-* =
-* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
-
-
- PAGE
-*
-* ======>> 1 <<
- 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
-*
-* ######>> 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
-*
-* ======>> 3 <<
- 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
-*
-* ######>> screen 15 <<
-* ======>> 4 <<
- FCB $86
- FCC 'BRANC' ; 'BRANCH'
- FCB $C8
- FDB EXEC-10
-BRAN FDB ZBYES Go steal code in ZBRANCH
-*
-* ======>> 5 <<
- FCB $87
- FCC '0BRANC' ; '0BRANCH'
- FCB $C8
- FDB BRAN-9
-ZBRAN FDB *+2
- 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 <<
- 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!
-*
-* ======>> 7 <<
- 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
-*
-* the subroutine :
-XPLOPS LDX RP
- ADDB 3,X add it to counter
- ADCA 2,X
- STB 3,X store new counter value
- STA 2,X
- RTS
-*
-XPLOF BSR XPLOPS
- SUBB 5,X
- SBCA 4,X
- BMI ZBYES
-*
-XPLONO LEAX 1,X ; done, don't branch back
- LEAX 1,X ;
- LEAX 1,X ;
- LEAX 1,X ;
- STX RP
- BRA ZBNO use ZBRAN to skip over unused delta
-*
-* ######>> screen 17 <<
-* ======>> 8 <<
- 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
-*
-* ======>> 9 <<
- FCB $81 I
- FCB $C9
- FDB XDO-7
-I FDB *+2
- LDX RP
- LEAX 1,X ;
- LEAX 1,X ;
- JMP GETX
-*
-* ######>> screen 18 <<
-* ======>> 10 <<
- 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
- 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:
-*
-* char-count + $80 lowest address
-* char 1
-* 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
-* "
-* "
-* "
-*
-* ======>> 11 <<
- 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
-*
-* not found :
-*
- CLRA ;
- CLRB ;
- JMP PUSHBA
-PFIND8 PSHS B ; ** emulating CBA:
- CMPA ,S+ ;
- BEQ PFIND2
-PFIND4 LDX PD
-PFIND9 LDB 0,X scan forward to end of this name
- LEAX 1,X ;
- BPL PFIND9
- BRA PFIND3
-*
-* 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
-*
-* ######>> screen 20 <<
-* ======>> 12 <<
- FCB $87
- FCC 'ENCLOS' ; 'ENCLOSE'
- FCB $C5
- FDB PFIND-9
-* 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 ;
-* 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
-* found NUL before non-delimiter, therefore there is no word
-ENCL6 LDB N found NUL
- PSHS B ;
- PSHS A ;
- INCB ;
- BRA ENCL7+2
-* found NUL following the word instead of SPACE
-ENCL7 LDB N
- PSHS B ; save EW
- PSHS A ;
-ENCL8 LDB N save NC
- JMP PUSHBA
-
- PAGE
-*
-* ######>> screen 21 <<
-* The next 4 words call system dependant I/O routines
-* which are listed after word "-->" ( lable: "arrow" )
-* in the dictionary.
-*
-* ======>> 13 <<
- 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
-*
-* ======>> 14 <<
- FCB $83
- FCC 'KE' ; 'KEY'
- FCB $D9
- FDB EMIT-7
-KEY FDB *+2
- JSR PKEY
- PSHS A ;
- CLRA ;
- PSHS A ;
- JMP NEXT
-*
-* ======>> 15 <<
- FCB $89
- FCC '?TERMINA' ; '?TERMINAL'
- FCB $CC
- FDB KEY-6
-QTERM FDB *+2
- JSR PQTER
- CLRB ;
- JMP PUSHBA stack the flag
-*
-* ======>> 16 <<
- FCB $82
- FCC 'C' ; 'CR'
- FCB $D2
- FDB QTERM-12
-CR FDB *+2
- JSR PCR
- JMP NEXT
-*
-* ######>> screen 22 <<
-* ======>> 17 <<
- 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
-*
-* ######>> screen 23 <<
-* ======>> 18 <<
- FCB $82
- FCC 'U' ; 'U*'
- FCB $AA
- FDB CMOVE-8
-USTAR FDB *+2
- BSR USTARS
- LEAS 1,S ;
- LEAS 1,S ;
- JMP PUSHBA
-*
-* The following is a subroutine which
-* multiplies top 2 words on stack,
-* leaving 32-bit result: high order word in A,B
-* low order word in 2nd word of stack.
-*
-USTARS LDA #16 bits/word counter
- PSHS A ;
- CLRA ;
- CLRB ;
- TFR S,X ; TSX :
-USTAR2 ROR 5,X shift multiplier
- ROR 6,X
- DEC 0,X done?
- BMI USTAR4
- BCC USTAR3
- ADDB 4,X
- ADCA 3,X
-USTAR3 RORA ;
- RORB ; shift result
- BRA USTAR2
-USTAR4 LEAS 1,S ; dump counter
- RTS
-*
-* ######>> screen 24 <<
-* ======>> 19 <<
- 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
-*
-* ######>> screen 25 <<
-* ======>> 20 <<
- 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
-*
-* ======>> 21 <<
- 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
-*
-* ======>> 22 <<
- 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
-*
-* ######>> screen 26 <<
-* ======>> 23 <<
- 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
-*
-* ======>> 24 <<
- 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
-* ======>> 25 <<
- FCB $83
- FCC 'RP' ; 'RP!'
- FCB $A1
- FDB SPSTOR-6
-RPSTOR FDB *+2
- LDX RINIT initialize from rom constant
- STX RP
- JMP NEXT
-*
-* ======>> 26 <<
- 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
-*
-* ######>> screen 27 <<
-* ======>> 27 <<
- 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
-*
-* ======>> 28 <<
- 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
-*
-* ======>> 29 <<
- 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
-*
-* ======>> 30 <<
- FCB $81 R
- FCB $D2
- FDB FROMR-5
-R FDB *+2
- LDX RP
- LEAX 1,X ;
- LEAX 1,X ;
- JMP GETX
-*
-* ######>> screen 28 <<
-* ======>> 31 <<
- 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
-*
-* ======>> 32 <<
- 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
-*
-* ######>> screen 29 <<
-* ======>> 33 <<
- 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
-*
-* ======>> 34 <<
- 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
-*
-* ======>> 35 <<
- 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
-*
-* ======>> 36 <<
- 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
-*
-* ######>> screen 30 <<
-* ======>> 37 <<
- 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
-*
-* ======>> 38 <<
- FCB $84
- FCC 'DRO' ; 'DROP'
- FCB $D0
- FDB OVER-7
-DROP FDB *+2
- LEAS 1,S ;
- LEAS 1,S ;
- JMP NEXT
-*
-* ======>> 39 <<
- 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
-*
-* ======>> 40 <<
- FCB $83
- FCC 'DU' ; 'DUP'
- FCB $D0
- FDB SWAP-7
-DUP FDB *+2
- PULS A ;
- PULS B ;
- PSHS B ;
- PSHS A ;
- JMP PUSHBA
-*
-* ######>> screen 31 <<
-* ======>> 41 <<
- 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
-*
-* ======>> 42 <<
- FCB $86
- FCC 'TOGGL' ; 'TOGGLE'
- FCB $C5
- FDB PSTORE-5
-TOGGLE FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
- FDB SEMIS
-*
-* ######>> screen 32 <<
-* ======>> 43 <<
- 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
-*
-* ======>> 44 <<
- 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
-*
-* ======>> 45 <<
- 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
-*
-* ======>> 46 <<
- 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
- PAGE
-*
-* ######>> screen 33 <<
-* ======>> 47 <<
- FCB $C1 : immediate
- FCB $BA
- FDB CSTORE-5
-COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
- FDB CREATE,RBRAK
- FDB PSCODE
-
-* Here is the IP pusher for allowing
-* nested words in the virtual machine:
-* ( ;S is the equivalent un-nester )
-
-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 <<
- FCB $C1 ; imnediate code
- FCB $BB
- FDB COLON-4
-SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
- FDB SEMIS
-*
-* ######>> screen 34 <<
-* ======>> 49 <<
- 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
-*
-* ======>> 50 <<
- FCB $88
- FCC 'VARIABL' ; 'VARIABLE'
- FCB $C5
- FDB CON-11
-VAR FDB DOCOL,CON,PSCODE
-DOVAR LDA W
- LDB W+1
- ADDB #2
- ADCA #0 A,B now contain the address of the variable
- JMP PUSHBA
-*
-* ======>> 51 <<
- 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
-*
-* ######>> screen 35 <<
-* ======>> 52 <<
- FCB $81
- FCB $B0 0
- FDB USER-7
-ZERO FDB DOCON
- FDB 0000
-*
-* ======>> 53 <<
- FCB $81
- FCB $B1 1
- FDB ZERO-4
-ONE FDB DOCON
- FDB 1
-*
-* ======>> 54 <<
- FCB $81
- FCB $B2 2
- FDB ONE-4
-TWO FDB DOCON
- FDB 2
-*
-* ======>> 55 <<
- FCB $81
- FCB $B3 3
- FDB TWO-4
-THREE FDB DOCON
- FDB 3
-*
-* ======>> 56 <<
- FCB $82
- FCC 'B' ; 'BL'
- FCB $CC
- FDB THREE-4
-BL FDB DOCON ascii blank
- FDB $20
-*
-* ======>> 57 <<
- FCB $85
- FCC 'FIRS' ; 'FIRST'
- FCB $D4
- FDB BL-5
-FIRST FDB DOCON
- FDB MEMEND-528 (132 * NBLK)
-*
-* ======>> 58 <<
- FCB $85
- FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
- FCB $D4
- FDB FIRST-8
-LIMIT FDB DOCON
- FDB MEMEND
-*
-* ======>> 59 <<
- FCB $85
- FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
- FCB $C6
- FDB LIMIT-8
-BBUF FDB DOCON
- FDB 128
-*
-* ======>> 60 <<
- 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
-*
-* ======>> 61 <<
- FCB $87
- FCC '+ORIGI' ; '+ORIGIN'
- FCB $CE
- FDB BSCR-8
-PORIG FDB DOCOL,LIT,ORIG,PLUS
- FDB SEMIS
-*
-* ######>> screen 36 <<
-* ======>> 62 <<
- FCB $82
- FCC 'S' ; 'S0'
- FCB $B0
- FDB PORIG-10
-SZERO FDB DOUSER
- FDB XSPZER-UORIG
-*
-* ======>> 63 <<
- FCB $82
- FCC 'R' ; 'R0'
- FCB $B0
- FDB SZERO-5
-RZERO FDB DOUSER
- FDB XRZERO-UORIG
-*
-* ======>> 64 <<
- FCB $83
- FCC 'TI' ; 'TIB'
- FCB $C2
- FDB RZERO-5
-TIB FDB DOUSER
- FDB XTIB-UORIG
-*
-* ======>> 65 <<
- FCB $85
- FCC 'WIDT' ; 'WIDTH'
- FCB $C8
- FDB TIB-6
-WIDTH FDB DOUSER
- FDB XWIDTH-UORIG
-*
-* ======>> 66 <<
- FCB $87
- FCC 'WARNIN' ; 'WARNING'
- FCB $C7
- FDB WIDTH-8
-WARN FDB DOUSER
- FDB XWARN-UORIG
-*
-* ======>> 67 <<
- FCB $85
- FCC 'FENC' ; 'FENCE'
- FCB $C5
- FDB WARN-10
-FENCE FDB DOUSER
- FDB XFENCE-UORIG
-*
-* ======>> 68 <<
- 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
-*
-* ======>> 68.5 <<
- FCB $88
- FCC 'VOC-LIN' ; 'VOC-LINK'
- FCB $CB
- FDB DP-5
-VOCLIN FDB DOUSER
- FDB XVOCL-UORIG
-*
-* ======>> 69 <<
- FCB $83
- FCC 'BL' ; 'BLK'
- FCB $CB
- FDB VOCLIN-11
-BLK FDB DOUSER
- FDB XBLK-UORIG
-*
-* ======>> 70 <<
- FCB $82
- FCC 'I' ; 'IN' : scan pointer for input line buffer
- FCB $CE
- FDB BLK-6
-IN FDB DOUSER
- FDB XIN-UORIG
-*
-* ======>> 71 <<
- FCB $83
- FCC 'OU' ; 'OUT'
- FCB $D4
- FDB IN-5
-OUT FDB DOUSER
- FDB XOUT-UORIG
-*
-* ======>> 72 <<
- FCB $83
- FCC 'SC' ; 'SCR'
- FCB $D2
- FDB OUT-6
-SCR FDB DOUSER
- FDB XSCR-UORIG
-* ######>> screen 37 <<
-*
-* ======>> 73 <<
- FCB $86
- FCC 'OFFSE' ; 'OFFSET'
- FCB $D4
- FDB SCR-6
-OFSET FDB DOUSER
- FDB XOFSET-UORIG
-*
-* ======>> 74 <<
- FCB $87
- FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
- FCB $D4
- FDB OFSET-9
-CONTXT FDB DOUSER
- FDB XCONT-UORIG
-*
-* ======>> 75 <<
- FCB $87
- FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
- FCB $D4
- FDB CONTXT-10
-CURENT FDB DOUSER
- FDB XCURR-UORIG
-*
-* ======>> 76 <<
- FCB $85
- FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
- FCB $C5
- FDB CURENT-10
-STATE FDB DOUSER
- FDB XSTATE-UORIG
-*
-* ======>> 77 <<
- FCB $84
- FCC 'BAS' ; 'BASE' : number base for all input & output
- FCB $C5
- FDB STATE-8
-BASE FDB DOUSER
- FDB XBASE-UORIG
-*
-* ======>> 78 <<
- FCB $83
- FCC 'DP' ; 'DPL'
- FCB $CC
- FDB BASE-7
-DPL FDB DOUSER
- FDB XDPL-UORIG
-*
-* ======>> 79 <<
- FCB $83
- FCC 'FL' ; 'FLD'
- FCB $C4
- FDB DPL-6
-FLD FDB DOUSER
- FDB XFLD-UORIG
-*
-* ======>> 80 <<
- FCB $83
- FCC 'CS' ; 'CSP'
- FCB $D0
- FDB FLD-6
-CSP FDB DOUSER
- FDB XCSP-UORIG
-*
-* ======>> 81 <<
- FCB $82
- FCC 'R' ; 'R#'
- FCB $A3
- FDB CSP-6
-RNUM FDB DOUSER
- FDB XRNUM-UORIG
-*
-* ======>> 82 <<
- FCB $83
- FCC 'HL' ; 'HLD'
- FCB $C4
- FDB RNUM-5
-HLD FDB DOCON
- FDB XHLD
-*
-* ======>> 82.5 <<== SPECIAL
- FCB $87
- FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
- FCB $D3
- FDB HLD-6
-COLUMS FDB DOUSER
- FDB XCOLUM-UORIG
-*
-* ######>> screen 38 <<
-* ======>> 83 <<
- FCB $82
- FCC '1' ; '1+'
- FCB $AB
- FDB COLUMS-10
-ONEP FDB DOCOL,ONE,PLUS
- FDB SEMIS
-*
-* ======>> 84 <<
- FCB $82
- FCC '2' ; '2+'
- FCB $AB
- FDB ONEP-5
-TWOP FDB DOCOL,TWO,PLUS
- FDB SEMIS
-*
-* ======>> 85 <<
- FCB $84
- FCC 'HER' ; 'HERE'
- FCB $C5
- FDB TWOP-5
-HERE FDB DOCOL,DP,AT
- FDB SEMIS
-*
-* ======>> 86 <<
- FCB $85
- FCC 'ALLO' ; 'ALLOT'
- FCB $D4
- FDB HERE-7
-ALLOT FDB DOCOL,DP,PSTORE
- FDB SEMIS
-*
-* ======>> 87 <<
- FCB $81 ; , (COMMA)
- FCB $AC
- FDB ALLOT-8
-COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
- FDB SEMIS
-*
-* ======>> 88 <<
- FCB $82
- FCC 'C' ; 'C,'
- FCB $AC
- FDB COMMA-4
-CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
- FDB SEMIS
-*
-* ======>> 89 <<
- FCB $81 ; -
- FCB $AD
- FDB CCOMM-5
-SUB FDB DOCOL,MINUS,PLUS
- FDB SEMIS
-*
-* ======>> 90 <<
- FCB $81 =
- FCB $BD
- FDB SUB-4
-EQUAL FDB DOCOL,SUB,ZEQU
- FDB SEMIS
-*
-* ======>> 91 <<
- 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
-*
-* ======>> 92 <<
- FCB $81 >
- FCB $BE
- FDB LESS-4
-GREAT FDB DOCOL,SWAP,LESS
- FDB SEMIS
-*
-* ======>> 93 <<
- FCB $83
- FCC 'RO' ; 'ROT'
- FCB $D4
- FDB GREAT-4
-ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
- FDB SEMIS
-*
-* ======>> 94 <<
- FCB $85
- FCC 'SPAC' ; 'SPACE'
- FCB $C5
- FDB ROT-6
-SPACE FDB DOCOL,BL,EMIT
- FDB SEMIS
-*
-* ======>> 95 <<
- 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
-*
-* ======>> 96 <<
- 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
-*
-* ======>> 97 <<
- FCB $84
- FCC '-DU' ; '-DUP'
- FCB $D0
- FDB MAX-6
-DDUP FDB DOCOL,DUP,ZBRAN
- FDB DDUP2-*
- FDB DUP
-DDUP2 FDB SEMIS
-*
-* ######>> screen 39 <<
-* ======>> 98 <<
- 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
-*
-* ======>> 99 <<
- FCB $86
- FCC 'LATES' ; 'LATEST'
- FCB $D4
- FDB TRAV-11
-LATEST FDB DOCOL,CURENT,AT,AT
- FDB SEMIS
-*
-* ======>> 100 <<
- FCB $83
- FCC 'LF' ; 'LFA'
- FCB $C1
- FDB LATEST-9
-LFA FDB DOCOL,CLITER
- FCB 4
- FDB SUB
- FDB SEMIS
-*
-* ======>> 101 <<
- FCB $83
- FCC 'CF' ; 'CFA'
- FCB $C1
- FDB LFA-6
-CFA FDB DOCOL,TWO,SUB
- FDB SEMIS
-*
-* ======>> 102 <<
- FCB $83
- FCC 'NF' ; 'NFA'
- FCB $C1
- FDB CFA-6
-NFA FDB DOCOL,CLITER
- FCB 5
- FDB SUB,ONE,MINUS,TRAV
- FDB SEMIS
-*
-* ======>> 103 <<
- FCB $83
- FCC 'PF' ; 'PFA'
- FCB $C1
- FDB NFA-6
-PFA FDB DOCOL,ONE,TRAV,CLITER
- FCB 5
- FDB PLUS
- FDB SEMIS
-*
-* ######>> screen 40 <<
-* ======>> 104 <<
- FCB $84
- FCC '!CS' ; '!CSP'
- FCB $D0
- FDB PFA-6
-SCSP FDB DOCOL,SPAT,CSP,STORE
- FDB SEMIS
-*
-* ======>> 105 <<
- FCB $86
- FCC '?ERRO' ; '?ERROR'
- FCB $D2
- FDB SCSP-7
-QERR FDB DOCOL,SWAP,ZBRAN
- FDB QERR2-*
- FDB ERROR,BRAN
- FDB QERR3-*
-QERR2 FDB DROP
-QERR3 FDB SEMIS
-*
-* ======>> 106 <<
- FCB $85
- FCC '?COM' ; '?COMP'
- FCB $D0
- FDB QERR-9
-QCOMP FDB DOCOL,STATE,AT,ZEQU,CLITER
- FCB $11
- FDB QERR
- FDB SEMIS
-*
-* ======>> 107 <<
- FCB $85
- FCC '?EXE' ; '?EXEC'
- FCB $C3
- FDB QCOMP-8
-QEXEC FDB DOCOL,STATE,AT,CLITER
- FCB $12
- FDB QERR
- FDB SEMIS
-*
-* ======>> 108 <<
- FCB $86
- FCC '?PAIR' ; '?PAIRS'
- FCB $D3
- FDB QEXEC-8
-QPAIRS FDB DOCOL,SUB,CLITER
- FCB $13
- FDB QERR
- FDB SEMIS
-*
-* ======>> 109 <<
- FCB $84
- FCC '?CS' ; '?CSP'
- FCB $D0
- FDB QPAIRS-9
-QCSP FDB DOCOL,SPAT,CSP,AT,SUB,CLITER
- FCB $14
- FDB QERR
- FDB SEMIS
-*
-* ======>> 110 <<
- FCB $88
- FCC '?LOADIN' ; '?LOADING'
- FCB $C7
- FDB QCSP-7
-QLOAD FDB DOCOL,BLK,AT,ZEQU,CLITER
- FCB $16
- FDB QERR
- FDB SEMIS
-*
-* ######>> screen 41 <<
-* ======>> 111 <<
- FCB $87
- FCC 'COMPIL' ; 'COMPILE'
- FCB $C5
- FDB QLOAD-11
-COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
- FDB SEMIS
-*
-* ======>> 112 <<
- FCB $C1 [ immediate
- FCB $DB
- FDB COMPIL-10
-LBRAK FDB DOCOL,ZERO,STATE,STORE
- FDB SEMIS
-*
-* ======>> 113 <<
- FCB $81 ]
- FCB $DD
- FDB LBRAK-4
-RBRAK FDB DOCOL,CLITER
- FCB $C0
- FDB STATE,STORE
- FDB SEMIS
-*
-* ======>> 114 <<
- FCB $86
- FCC 'SMUDG' ; 'SMUDGE'
- FCB $C5
- FDB RBRAK-4
-SMUDGE FDB DOCOL,LATEST,CLITER
- FCB $20
- FDB TOGGLE
- FDB SEMIS
-*
-* ======>> 115 <<
- FCB $83
- FCC 'HE' ; 'HEX'
- FCB $D8
- FDB SMUDGE-9
-HEX FDB DOCOL
- FDB CLITER
- FCB 16
- FDB BASE,STORE
- FDB SEMIS
-*
-* ======>> 116 <<
- FCB $87
- FCC 'DECIMA' ; 'DECIMAL'
- FCB $CC
- FDB HEX-6
-DEC FDB DOCOL
- FDB CLITER
- FCB 10 note: hex "A"
- FDB BASE,STORE
- FDB SEMIS
-*
-* ######>> screen 42 <<
-* ======>> 117 <<
- FCB $87
- FCC '(;CODE' ; '(;CODE)'
- FCB $A9
- FDB DEC-10
-PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
- FDB SEMIS
-*
-* ======>> 118 <<
- FCB $C5 immediate
- FCC ';COD' ; ';CODE'
- FCB $C5
- FDB PSCODE-10
-SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
- FDB SEMIS
-* note: "QSTACK" will be replaced by "ASSEMBLER" later
-*
-* ######>> screen 43 <<
-* ======>> 119 <<
- FCB $87
- FCC '<BUILD' ; '<BUILDS'
- FCB $D3
- FDB SEMIC-8
-BUILDS FDB DOCOL,ZERO,CON
- FDB SEMIS
-*
-* ======>> 120 <<
- FCB $85
- FCC 'DOES' ; 'DOES>'
- FCB $BE
- FDB BUILDS-10
-DOES FDB DOCOL,FROMR,TWOP,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
-*
-* ######>> screen 44 <<
-* ======>> 121 <<
- FCB $85
- FCC 'COUN' ; 'COUNT'
- FCB $D4
- FDB DOES-8
-COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
- FDB SEMIS
-*
-* ======>> 122 <<
- FCB $84
- FCC 'TYP' ; 'TYPE'
- FCB $C5
- FDB COUNT-8
-TYPE FDB DOCOL,DDUP,ZBRAN
- FDB TYPE3-*
- FDB OVER,PLUS,SWAP,XDO
-TYPE2 FDB I,CAT,EMIT,XLOOP
- FDB TYPE2-*
- FDB BRAN
- FDB TYPE4-*
-TYPE3 FDB DROP
-TYPE4 FDB SEMIS
-*
-* ======>> 123 <<
- FCB $89
- FCC '-TRAILIN' ; '-TRAILING'
- FCB $C7
- FDB TYPE-7
-DTRAIL FDB DOCOL,DUP,ZERO,XDO
-DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
- FDB SUB,ZBRAN
- FDB DTRAL3-*
- FDB LEAVE,BRAN
- FDB DTRAL4-*
-DTRAL3 FDB ONE,SUB
-DTRAL4 FDB XLOOP
- FDB DTRAL2-*
- FDB SEMIS
-*
-* ======>> 124 <<
- FCB $84
- FCC '(."' ; '(.")'
- FCB $A9
- FDB DTRAIL-12
-PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
- FDB FROMR,PLUS,TOR,TYPE
- FDB SEMIS
-*
-* ======>> 125 <<
- FCB $C2 immediate
- FCC '.' ; '."'
- FCB $A2
- FDB PDOTQ-7
-DOTQ FDB DOCOL
- FDB CLITER
- FCB $22 ascii quote
- FDB STATE,AT,ZBRAN
- FDB DOTQ1-*
- FDB COMPIL,PDOTQ,WORD
- FDB HERE,CAT,ONEP,ALLOT,BRAN
- FDB DOTQ2-*
-DOTQ1 FDB WORD,HERE,COUNT,TYPE
-DOTQ2 FDB SEMIS
-*
-* ######>> screen 45 <<
-* ======>> 126 <<== MACHINE DEPENDENT
- FCB $86
- FCC '?STAC' ; '?STACK'
- FCB $CB
- FDB DOTQ-5
-QSTACK FDB DOCOL,CLITER
- FCB $12
- FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
- 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
- FDB PLUS,LESS,ZBRAN
- FDB QSTAC3-*
- FDB TWO
- FDB QERR
-* prints 'full stack'
-*
-QSTAC3 FDB SEMIS
-*
-* ======>> 127 << this word's function
-* is done by ?STACK in this version
-* FCB $85
-* FCC 4,?FREE
-* FCB $C5
-* FDB QSTACK-9
-*QFREE FDB DOCOL,SPAT,HERE,CLITER
-* FCB $80
-* FDB PLUS,LESS,TWO,QERR,SEMIS
-*
-* ######>> screen 46 <<
-* ======>> 128 <<
- 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
- FCB 8 ( backspace character to emit )
- FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS
- FDB TOR,SUB,BRAN
- FDB EXPEC6-*
-EXPEC3 FDB DUP,CLITER
- FCB $D ( carriage return )
- FDB EQUAL,ZBRAN
- FDB EXPEC4-*
- FDB LEAVE,DROP,BL,ZERO,BRAN
- FDB EXPEC5-*
-EXPEC4 FDB DUP
-EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
-EXPEC6 FDB EMIT,XLOOP
- FDB EXPEC2-*
- FDB DROP
- FDB SEMIS
-*
-* ======>> 129 <<
- FCB $85
- FCC 'QUER' ; 'QUERY'
- FCB $D9
- FDB EXPECT-9
-QUERY FDB DOCOL,TIB,AT,COLUMS
- FDB AT,EXPECT,ZERO,IN,STORE
- FDB SEMIS
-*
-* ======>> 130 <<
- FCB $C1 immediate < carriage return >
- FCB $80
- FDB QUERY-8
-NULL FDB DOCOL,BLK,AT,ZBRAN
- FDB NULL2-*
- FDB ONE,BLK,PSTORE
- FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
- FDB ZEQU
-* check for end of screen
- FDB ZBRAN
- FDB NULL1-*
- FDB QEXEC,FROMR,DROP
-NULL1 FDB BRAN
- FDB NULL3-*
-NULL2 FDB FROMR,DROP
-NULL3 FDB SEMIS
-*
-* ######>> screen 47 <<
-* ======>> 133 <<
- FCB $84
- FCC 'FIL' ; 'FILL'
- FCB $CC
- FDB NULL-4
-FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
- FDB FROMR,ONE,SUB,CMOVE
- FDB SEMIS
-*
-* ======>> 134 <<
- FCB $85
- FCC 'ERAS' ; 'ERASE'
- FCB $C5
- FDB FILL-7
-ERASE FDB DOCOL,ZERO,FILL
- FDB SEMIS
-*
-* ======>> 135 <<
- FCB $86
- FCC 'BLANK' ; 'BLANKS'
- FCB $D3
- FDB ERASE-8
-BLANKS FDB DOCOL,BL,FILL
- FDB SEMIS
-*
-* ======>> 136 <<
- FCB $84
- FCC 'HOL' ; 'HOLD'
- FCB $C4
- FDB BLANKS-9
-HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
- FDB SEMIS
-*
-* ======>> 137 <<
- FCB $83
- FCC 'PA' ; 'PAD'
- FCB $C4
- FDB HOLD-7
-PAD FDB DOCOL,HERE,CLITER
- FCB $44
- FDB PLUS
- FDB SEMIS
-*
-* ######>> screen 48 <<
-* ======>> 138 <<
- FCB $84
- FCC 'WOR' ; 'WORD'
- FCB $C4
- FDB PAD-6
-WORD FDB DOCOL,BLK,AT,ZBRAN
- FDB WORD2-*
- FDB BLK,AT,BLOCK,BRAN
- FDB WORD3-*
-WORD2 FDB TIB,AT
-WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,CLITER
- FCB 34
- FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
- FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
- FDB SEMIS
-*
-* ######>> screen 49 <<
-* ======>> 139 <<
- 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 SWAP,BASE,AT,USTAR,DROP,ROT,BASE
- FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
- FDB PNUMB3-*
- FDB ONE,DPL,PSTORE
-PNUMB3 FDB FROMR,BRAN
- FDB PNUMB2-*
-PNUMB4 FDB FROMR
- FDB SEMIS
-*
-* ======>> 140 <<
- FCB $86
- FCC 'NUMBE' ; 'NUMBER'
- FCB $D2
- FDB PNUMB-11
-NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,CLITER
- 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
- FCC "."
- FDB SUB,ZERO,QERR,ZERO,BRAN
- FDB NUMB1-*
-NUMB2 FDB DROP,FROMR,ZBRAN
- FDB NUMB3-*
- FDB DMINUS
-NUMB3 FDB SEMIS
-*
-* ======>> 141 <<
- 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 DROP,HERE,LATEST,PFIND
-DFIND2 FDB SEMIS
-*
-* ######>> screen 50 <<
-* ======>> 142 <<
- FCB $87
- FCC '(ABORT' ; '(ABORT)'
- FCB $A9
- FDB DFIND-8
-PABORT FDB DOCOL,ABORT
- FDB SEMIS
-*
-* ======>> 143 <<
- FCB $85
- FCC 'ERRO' ; 'ERROR'
- FCB $D2
- FDB PABORT-10
-ERROR FDB DOCOL,WARN,AT,ZLESS
- FDB ZBRAN
-* 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 )
- FCC " ? "
- FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
- FDB SEMIS
-*
-* ======>> 144 <<
- FCB $83
- FCC 'ID' ; 'ID.'
- FCB $AE
- FDB ERROR-8
-IDDOT FDB DOCOL,PAD,CLITER
- FCB 32
- FDB CLITER
- FCB $5F ( underline )
- FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
- FDB SWAP,CMOVE,PAD,COUNT,CLITER
- FCB 31
- FDB AND,TYPE,SPACE
- FDB SEMIS
-*
-* ######>> screen 51 <<
-* ======>> 145 <<
- FCB $86
- FCC 'CREAT' ; 'CREATE'
- FCB $C5
- FDB IDDOT-6
-CREATE FDB DOCOL,DFIND,ZBRAN
- FDB CREAT2-*
- FDB DROP,PDOTQ
- FCB 8
- FCB 7 ( bel )
- FCC "redef: "
- FDB NFA,IDDOT,CLITER
- 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
- FCB $80
- FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
- FDB HERE,TWOP,COMMA
- FDB SEMIS
-*
-* ######>> screen 52 <<
-* ======>> 146 <<
- FCB $C9 immediate
- FCC '[COMPILE' ; '[COMPILE]'
- FCB $DD
- FDB CREATE-9
-BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
- FDB SEMIS
-*
-* ======>> 147 <<
- FCB $C7 immediate
- FCC 'LITERA' ; 'LITERAL'
- FCB $CC
- FDB BCOMP-12
-LITER FDB DOCOL,STATE,AT,ZBRAN
- FDB LITER2-*
- FDB COMPIL,LIT,COMMA
-LITER2 FDB SEMIS
-*
-* ======>> 148 <<
- FCB $C8 immediate
- FCC 'DLITERA' ; 'DLITERAL'
- FCB $CC
- FDB LITER-10
-DLITER FDB DOCOL,STATE,AT,ZBRAN
- FDB DLITE2-*
- FDB SWAP,LITER,LITER
-DLITE2 FDB SEMIS
-*
-* ######>> screen 53 <<
-* ======>> 149 <<
- FCB $89
- FCC 'INTERPRE' ; 'INTERPRET'
- FCB $D4
- FDB DLITER-11
-INTERP FDB DOCOL
-INTER2 FDB DFIND,ZBRAN
- FDB INTER5-*
- FDB STATE,AT,LESS
- FDB ZBRAN
- FDB INTER3-*
- FDB CFA,COMMA,BRAN
- FDB INTER4-*
-INTER3 FDB CFA,EXEC
-INTER4 FDB BRAN
- FDB INTER7-*
-INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
- FDB INTER6-*
- FDB DLITER,BRAN
- FDB INTER7-*
-INTER6 FDB DROP,LITER
-INTER7 FDB QSTACK,BRAN
- FDB INTER2-*
-* FDB SEMIS never executed
-
-*
-* ######>> screen 54 <<
-* ======>> 150 <<
- FCB $89
- FCC 'IMMEDIAT' ; 'IMMEDIATE'
- FCB $C5
- FDB INTERP-12
-IMMED FDB DOCOL,LATEST,CLITER
- FCB $40
- FDB TOGGLE
- FDB SEMIS
-*
-* ======>> 151 <<
- 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
- FDB SEMIS
-*
-* ======>> 152 <<
-*
-* Note: FORTH does not go here in the rom-able dictionary,
-* since FORTH is a type of variable.
-*
-*
-* ======>> 153 <<
- FCB $8B
- FCC 'DEFINITION' ; 'DEFINITIONS'
- FCB $D3
- FDB VOCAB-13
-DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
- FDB SEMIS
-*
-* ======>> 154 <<
- FCB $C1 immediate (
- FCB $A8
- FDB DEFIN-14
-PAREN FDB DOCOL,CLITER
- FCC ")"
- FDB WORD
- FDB SEMIS
-*
-* ######>> screen 55 <<
-* ======>> 155 <<
- FCB $84
- FCC 'QUI' ; 'QUIT'
- FCB $D4
- FDB PAREN-4
-QUIT FDB DOCOL,ZERO,BLK,STORE
- FDB LBRAK
-*
-* Here is the outer interpretter
-* which gets a line of input, does it, prints " OK"
-* then repeats :
-QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
- FDB ZBRAN
- FDB QUIT3-*
- FDB PDOTQ
- FCB 3
- FCC ' OK' ; ' OK'
-QUIT3 FDB BRAN
- FDB QUIT2-*
-* FDB SEMIS ( never executed )
-*
-* ======>> 156 <<
- FCB $85
- FCC 'ABOR' ; 'ABORT'
- FCB $D4
- FDB QUIT-7
-ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
- FCB 8
- FCC "Forth-68"
- FDB FORTH,DEFIN
- FDB QUIT
-* FDB SEMIS never executed
- PAGE
-*
-* ######>> screen 56 <<
-* bootstrap code... moves rom contents to ram :
-* ======>> 157 <<
- FCB $84
- FCC 'COL' ; 'COLD'
- FCB $C4
- FDB ABORT-8
-COLD FDB *+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
- 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
- BNE WARM2
-*
- 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
- LDX #0
- STX BRKPT clear breakpoint address
- JMP RPSTOR+2 start the virtual machine running !
-*
-* Here is the stuff that gets copied to ram :
-* at address $140:
-*
-RAM FDB $3000,$3000,0,0
-
-* ======>> (152) <<
- FCB $C5 immediate
- FCC 'FORT' ; 'FORTH'
- FCB $C8
- FDB NOOP-7
-RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
- FDB 0
- FCC "(C) Forth Interest Group, 1979"
- FCB $84
- FCC 'TAS' ; 'TASK'
- FCB $CB
- FDB FORTH-8
-RTASK FDB DOCOL,SEMIS
-ERAM FCC "David Lion"
- PAGE
-*
-* ######>> screen 57 <<
-* ======>> 158 <<
- FCB $84
- FCC 'S->' ; 'S->D'
- FCB $C4
- FDB COLD-7
-STOD FDB DOCOL,DUP,ZLESS,MINUS
- FDB SEMIS
-
-
-*
-* ======>> 159 <<
- FCB $81 ; *
- FCB $AA
- FDB STOD-7
-STAR FDB *+2
- JSR USTARS
- LEAS 1,S ;
- LEAS 1,S ;
- JMP NEXT
-*
-* ======>> 160 <<
- FCB $84
- FCC '/MO' ; '/MOD'
- FCB $C4
- FDB STAR-4
-SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
- FDB SEMIS
-*
-* ======>> 161 <<
- FCB $81 ; /
- FCB $AF
- FDB SLMOD-7
-SLASH FDB DOCOL,SLMOD,SWAP,DROP
- FDB SEMIS
-*
-* ======>> 162 <<
- FCB $83
- FCC 'MO' ; 'MOD'
- FCB $C4
- FDB SLASH-4
-MOD FDB DOCOL,SLMOD,DROP
- FDB SEMIS
-*
-* ======>> 163 <<
- FCB $85
- FCC '*/MO' ; '*/MOD'
- FCB $C4
- FDB MOD-6
-SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
- FDB SEMIS
-*
-* ======>> 164 <<
- FCB $82
- FCC '*' ; '*/'
- FCB $AF
- FDB SSMOD-8
-SSLASH FDB DOCOL,SSMOD,SWAP,DROP
- FDB SEMIS
-*
-* ======>> 165 <<
- FCB $85
- FCC 'M/MO' ; 'M/MOD'
- FCB $C4
- FDB SSLASH-5
-MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
- FDB FROMR,SWAP,TOR,USLASH,FROMR
- FDB SEMIS
-*
-* ======>> 166 <<
- FCB $83
- FCC 'AB' ; 'ABS'
- FCB $D3
- FDB MSMOD-8
-ABS FDB DOCOL,DUP,ZLESS,ZBRAN
- FDB ABS2-*
- FDB MINUS
-ABS2 FDB SEMIS
-*
-* ======>> 167 <<
- FCB $84
- FCC 'DAB' ; 'DABS'
- FCB $D3
- FDB ABS-6
-DABS FDB DOCOL,DUP,ZLESS,ZBRAN
- FDB DABS2-*
- FDB DMINUS
-DABS2 FDB SEMIS
-*
-* ######>> screen 58 <<
-* Disc primatives :
-* ======>> 168 <<
- FCB $83
- FCC 'US' ; 'USE'
- FCB $C5
- FDB DABS-7
-USE FDB DOCON
- FDB XUSE
-* ======>> 169 <<
- FCB $84
- FCC 'PRE' ; 'PREV'
- FCB $D6
- FDB USE-6
-PREV FDB DOCON
- FDB XPREV
-* ======>> 170 <<
- FCB $84
- FCC '+BU' ; '+BUF'
- FCB $C6
- FDB PREV-7
-PBUF FDB DOCOL,CLITER
- FCB $84
- FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
- FDB PBUF2-*
- FDB DROP,FIRST
-PBUF2 FDB DUP,PREV,AT,SUB
- FDB SEMIS
-*
-* ======>> 171 <<
- FCB $86
- FCC 'UPDAT' ; 'UPDATE'
- FCB $C5
- FDB PBUF-7
-UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
- FDB SEMIS
-*
-* ======>> 172 <<
- FCB $8D
- FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
- FCB $D3
- FDB UPDATE-9
-MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
- FDB SEMIS
-*
-* ======>> 173 <<
- FCB $83
- FCC 'DR' ; 'DR0'
- FCB $B0
- FDB MTBUF-16
-DRZERO FDB DOCOL,ZERO,OFSET,STORE
- FDB SEMIS
-*
-* ======>> 174 <<== system dependant word
- FCB $83
- FCC 'DR' ; 'DR1'
- FCB $B1
- FDB DRZERO-6
-DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
- FDB SEMIS
-*
-* ######>> screen 59 <<
-* ======>> 175 <<
- FCB $86
- FCC 'BUFFE' ; 'BUFFER'
- FCB $D2
- FDB DRONE-6
-BUFFER FDB DOCOL,USE,AT,DUP,TOR
-BUFFR2 FDB PBUF,ZBRAN
- FDB BUFFR2-*
- 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 SEMIS
-*
-* ######>> screen 60 <<
-* ======>> 176 <<
- 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-*
-BLOCK3 FDB PBUF,ZEQU,ZBRAN
- FDB BLOCK4-*
- FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
-BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
- FDB BLOCK3-*
- FDB DUP,PREV,STORE
-BLOCK5 FDB FROMR,DROP,TWOP
- FDB SEMIS
-*
-* ######>> screen 61 <<
-* ======>> 177 <<
- FCB $86
- FCC '(LINE' ; '(LINE)'
- FCB $A9
- FDB BLOCK-8
-PLINE FDB DOCOL,TOR,CLITER
- FCB $40
- FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,CLITER
- FCB $40
- FDB SEMIS
-*
-* ======>> 178 <<
- FCB $85
- FCC '.LIN' ; '.LINE'
- FCB $C5
- FDB PLINE-9
-DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
- FDB SEMIS
-*
-* ======>> 179 <<
- FCB $87
- FCC 'MESSAG' ; 'MESSAGE'
- FCB $C5
- FDB DLINE-8
-MESS FDB DOCOL,WARN,AT,ZBRAN
- FDB MESS3-*
- FDB DDUP,ZBRAN
- FDB MESS3-*
- FDB CLITER
- FCB 4
- FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
- FDB MESS4-*
-MESS3 FDB PDOTQ
- FCB 6
- FCC 'err # ' ; 'err # '
- FDB DOT
-MESS4 FDB SEMIS
-*
-* ======>> 180 <<
- FCB $84
- FCC 'LOA' ; 'LOAD' : input:scr #
- FCB $C4
- FDB MESS-10
-LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
- FDB BSCR,STAR,BLK,STORE
- FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
- FDB SEMIS
-*
-* ======>> 181 <<
- FCB $C3
- FCC '--' ; '-->'
- FCB $BE
- FDB LOAD-7
-ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
- FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
- FDB SEMIS
- PAGE
-*
-*
-* ######>> screen 63 <<
-* The next 4 subroutines are machine dependent, and are
-* called by words 13 through 16 in the dictionary.
-*
-* ======>> 182 << code for EMIT
-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
-* 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
-* input buffer full
- 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
-
-
- PAGE
-*
-* ######>> screen 66 <<
-* ======>> 187 <<
- FCB $85
- FCC '?DIS' ; '?DISC'
- FCB $C3
- FDB ARROW-6
-QDISC FDB *+2
- JMP NEXT
-*
-* ######>> screen 67 <<
-* ======>> 189 <<
- FCB $8B
- FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
- FCB $C5
- FDB QDISC-8
-BWRITE FDB *+2
- JMP NEXT
-*
-* ######>> screen 68 <<
-* ======>> 190 <<
- FCB $8A
- FCC 'BLOCK-REA' ; 'BLOCK-READ'
- FCB $C4
- FDB BWRITE-14
-BREAD FDB *+2
- JMP NEXT
-*
-*The next 3 words are written to create a substitute for disc
-* mass memory,located between $3210 & $3FFF in ram.
-* ======>> 190.1 <<
- FCB $82
- FCC 'L' ; 'LO'
- FCB $CF
- FDB BREAD-13
-LO FDB DOCON
- FDB MEMEND a system dependent equate at front
-*
-* ======>> 190.2 <<
- FCB $82
- FCC 'H' ; 'HI'
- FCB $C9
- FDB LO-5
-HI FDB DOCON
- FDB MEMTOP ( $3FFF in this version )
-*
-* ######>> screen 69 <<
-* ======>> 191 <<
- 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 PDOTQ
- FCB 8
- FCC ' Range ?' ; ' Range ?'
- FDB QUIT
-RW2 FDB FROMR,ZBRAN
- FDB RW3-*
- FDB SWAP
-RW3 FDB BBUF,CMOVE
- FDB SEMIS
-*
-* ######>> screen 72 <<
-* ======>> 192 <<
- FCB $C1 immediate
- FCB $A7 ' ( tick )
- FDB RW-6
-TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
- FDB SEMIS
-*
-* ======>> 193 <<
- FCB $86
- FCC 'FORGE' ; 'FORGET'
- FCB $D4
- FDB TICK-4
-FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,CLITER
- FCB $18
- FDB QERR,TICK,DUP,FENCE,AT,LESS,CLITER
- FCB $15
- FDB QERR,DUP,ZERO,PORIG,GREAT,CLITER
- FCB $15
- FDB QERR,DUP,NFA,DP,STORE,LFA,AT,CONTXT,AT,STORE
- FDB SEMIS
-*
-* ######>> screen 73 <<
-* ======>> 194 <<
- FCB $84
- FCC 'BAC' ; 'BACK'
- FCB $CB
- FDB FORGET-9
-BACK FDB DOCOL,HERE,SUB,COMMA
- FDB SEMIS
-*
-* ======>> 195 <<
- FCB $C5
- FCC 'BEGI' ; 'BEGIN'
- FCB $CE
- FDB BACK-7
-BEGIN FDB DOCOL,QCOMP,HERE,ONE
- FDB SEMIS
-*
-* ======>> 196 <<
- FCB $C5
- FCC 'ENDI' ; 'ENDIF'
- FCB $C6
- FDB BEGIN-8
-ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE
- FDB OVER,SUB,SWAP,STORE
- FDB SEMIS
-*
-* ======>> 197 <<
- FCB $C4
- FCC 'THE' ; 'THEN'
- FCB $CE
- FDB ENDIF-8
-THEN FDB DOCOL,ENDIF
- FDB SEMIS
-*
-* ======>> 198 <<
- FCB $C2
- FCC 'D' ; 'DO'
- FCB $CF
- FDB THEN-7
-DO FDB DOCOL,COMPIL,XDO,HERE,THREE
- FDB SEMIS
-*
-* ======>> 199 <<
- FCB $C4
- FCC 'LOO' ; 'LOOP'
- FCB $D0
- FDB DO-5
-LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK
- FDB SEMIS
-*
-* ======>> 200 <<
- FCB $C5
- FCC '+LOO' ; '+LOOP'
- FCB $D0
- FDB LOOP-7
-PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK
- FDB SEMIS
-*
-* ======>> 201 <<
- FCB $C5
- FCC 'UNTI' ; 'UNTIL' : ( same as END )
- FCB $CC
- FDB PLOOP-8
-UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK
- FDB SEMIS
-*
-* ######>> screen 74 <<
-* ======>> 202 <<
- FCB $C3
- FCC 'EN' ; 'END'
- FCB $C4
- FDB UNTIL-8
-END FDB DOCOL,UNTIL
- FDB SEMIS
-*
-* ======>> 203 <<
- FCB $C5
- FCC 'AGAI' ; 'AGAIN'
- FCB $CE
- FDB END-6
-AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK
- FDB SEMIS
-*
-* ======>> 204 <<
- FCB $C6
- FCC 'REPEA' ; 'REPEAT'
- FCB $D4
- FDB AGAIN-8
-REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR
- FDB TWO,SUB,ENDIF
- FDB SEMIS
-*
-* ======>> 205 <<
- FCB $C2
- FCC 'I' ; 'IF'
- FCB $C6
- FDB REPEAT-9
-IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO
- FDB SEMIS
-*
-* ======>> 206 <<
- 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 SEMIS
-*
-* ======>> 207 <<
- FCB $C5
- FCC 'WHIL' ; 'WHILE'
- FCB $C5
- FDB ELSE-7
-WHILE FDB DOCOL,IF,TWOP
- FDB SEMIS
-*
-* ######>> screen 75 <<
-* ======>> 208 <<
- FCB $86
- FCC 'SPACE' ; 'SPACES'
- FCB $D3
- FDB WHILE-8
-SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
- FDB SPACE3-*
- FDB ZERO,XDO
-SPACE2 FDB SPACE,XLOOP
- FDB SPACE2-*
-SPACE3 FDB SEMIS
-*
-* ======>> 209 <<
- FCB $82
- FCC '<' ; '<#'
- FCB $A3
- FDB SPACES-9
-BDIGS FDB DOCOL,PAD,HLD,STORE
- FDB SEMIS
-*
-* ======>> 210 <<
- FCB $82
- FCC '#' ; '#>'
- FCB $BE
- FDB BDIGS-5
-EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
- FDB SEMIS
-*
-* ======>> 211 <<
- FCB $84
- FCC 'SIG' ; 'SIGN'
- FCB $CE
- FDB EDIGS-5
-SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
- FDB SIGN2-*
- FDB CLITER
- FCC "-"
- FDB HOLD
-SIGN2 FDB SEMIS
-*
-* ======>> 212 <<
- FCB $81 #
- FCB $A3
- FDB SIGN-7
-DIG FDB DOCOL,BASE,AT,MSMOD,ROT,CLITER
- FCB 9
- FDB OVER,LESS,ZBRAN
- FDB DIG2-*
- FDB CLITER
- FCB 7
- FDB PLUS
-DIG2 FDB CLITER
- FCC "0" ascii zero
- FDB PLUS,HOLD
- FDB SEMIS
-*
-* ======>> 213 <<
- FCB $82
- FCC '#' ; '#S'
- FCB $D3
- FDB DIG-4
-DIGS FDB DOCOL
-DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
- FDB DIGS2-*
- FDB SEMIS
-*
-* ######>> screen 76 <<
-* ======>> 214 <<
- FCB $82
- FCC '.' ; '.R'
- FCB $D2
- FDB DIGS-5
-DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
- FDB SEMIS
-*
-* ======>> 215 <<
- FCB $83
- FCC 'D.' ; 'D.R'
- FCB $D2
- FDB DOTR-5
-DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
- FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
- FDB SEMIS
-*
-* ======>> 216 <<
- FCB $82
- FCC 'D' ; 'D.'
- FCB $AE
- FDB DDOTR-6
-DDOT FDB DOCOL,ZERO,DDOTR,SPACE
- FDB SEMIS
-*
-* ======>> 217 <<
- FCB $81 .
- FCB $AE
- FDB DDOT-5
-DOT FDB DOCOL,STOD,DDOT
- FDB SEMIS
-*
-* ======>> 218 <<
- FCB $81 ?
- FCB $BF
- FDB DOT-4
-QUEST FDB DOCOL,AT,DOT
- FDB SEMIS
-*
-* ######>> screen 77 <<
-* ======>> 219 <<
- FCB $84
- FCC 'LIS' ; 'LIST'
- FCB $D4
- FDB QUEST-4
-LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
- FCB 6
- FCC "SCR # "
- FDB DOT,CLITER
- FCB $10
- FDB ZERO,XDO
-LIST2 FDB CR,I,THREE
- FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
- FDB LIST2-*
- FDB CR
- FDB SEMIS
-*
-* ======>> 220 <<
- FCB $85
- FCC 'INDE' ; 'INDEX'
- FCB $D8
- FDB LIST-7
-INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
-INDEX2 FDB CR,I,THREE
- FDB DOTR,SPACE,ZERO,I,DLINE
- FDB QTERM,ZBRAN
- FDB INDEX3-*
- FDB LEAVE
-INDEX3 FDB XLOOP
- FDB INDEX2-*
- FDB SEMIS
-*
-* ======>> 221 <<
- FCB $85
- FCC 'TRIA' ; 'TRIAD'
- FCB $C4
- FDB INDEX-8
-TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
- FDB THREE,OVER,PLUS,SWAP,XDO
-TRIAD2 FDB CR,I
- FDB LIST,QTERM,ZBRAN
- FDB TRIAD3-*
- FDB LEAVE
-TRIAD3 FDB XLOOP
- FDB TRIAD2-*
- FDB CR,CLITER
- FCB $0F
- FDB MESS,CR
- FDB SEMIS
-*
-* ######>> screen 78 <<
-* ======>> 222 <<
- FCB $85
- FCC 'VLIS' ; 'VLIST'
- FCB $D4
- FDB TRIAD-8
-VLIST FDB DOCOL,CLITER
- FCB $80
- FDB OUT,STORE,CONTXT,AT,AT
-VLIST1 FDB OUT,AT,COLUMS,AT,CLITER
- FCB 32
- FDB SUB,GREAT,ZBRAN
- FDB VLIST2-*
- FDB CR,ZERO,OUT,STORE
-VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
- FDB DUP,ZEQU,QTERM,OR,ZBRAN
- FDB VLIST1-*
- FDB DROP
- FDB SEMIS
-*
-* ======>> XX <<
- FCB $84
- FCC 'NOO' ; 'NOOP'
- FCB $D0
- FDB VLIST-8
-NOOP FDB NEXT a useful no-op
-ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
-
-
-
-
-
-
-
- PAGE
- OPT L
- END
--- /dev/null
+ (fig-forth-auto680):00001 OPT PRT
+ (fig-forth-auto680):00002
+ (fig-forth-auto680):00003 * fig-FORTH FOR 6809
+ (fig-forth-auto680):00004 * ASSEMBLY SOURCE LISTING
+ (fig-forth-auto680):00005
+ (fig-forth-auto680):00006 * RELEASE 0
+ (fig-forth-auto680):00007 * JAN 2019
+ (fig-forth-auto680):00008 * WITH COMPILER SECURITY
+ (fig-forth-auto680):00009 * AND VARIABLE LENGTH NAMES
+ (fig-forth-auto680):00010 *
+ (fig-forth-auto680):00011 * Adapted by Joel Matthew Rees
+ (fig-forth-auto680):00012 * from fig-FORTH for 6800 by Dave Lion, et. al.
+ (fig-forth-auto680):00013
+ (fig-forth-auto680):00014 * This free/libre/open source publication is provided
+ (fig-forth-auto680):00015 * through the courtesy of:
+ (fig-forth-auto680):00016 * FORTH
+ (fig-forth-auto680):00017 * INTEREST
+ (fig-forth-auto680):00018 * GROUP
+ (fig-forth-auto680):00019 * fig
+ (fig-forth-auto680):00020 * and other interested parties.
+ (fig-forth-auto680):00021
+ (fig-forth-auto680):00022 * Ancient address:
+ (fig-forth-auto680):00023 * P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
+ (fig-forth-auto680):00024 * URL: http://www.forth.org
+ (fig-forth-auto680):00025 * Further distribution must include this notice.
+ (fig-forth-auto680):00026 PAGE
+ (fig-forth-auto680):00027 NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
+ (fig-forth-auto680):00028 OPT NOG,PAG
+ (fig-forth-auto680):00029 * filename fig-forth-auto6809opt.asm
+ (fig-forth-auto680):00030 * === FORTH-6809 {date} {time}
+ (fig-forth-auto680):00031
+ (fig-forth-auto680):00032
+ (fig-forth-auto680):00033 * Permission is hereby granted, free of charge, to any person obtaining a copy
+ (fig-forth-auto680):00034 * of this software and associated documentation files (the "Software"), to deal
+ (fig-forth-auto680):00035 * in the Software without restriction, including without limitation the rights
+ (fig-forth-auto680):00036 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+ (fig-forth-auto680):00037 * copies of the Software, and to permit persons to whom the Software is
+ (fig-forth-auto680):00038 * furnished to do so, subject to the following conditions:
+ (fig-forth-auto680):00039 *
+ (fig-forth-auto680):00040 * The above copyright notice and this permission notice shall be included in
+ (fig-forth-auto680):00041 * all copies or substantial portions of the Software.
+ (fig-forth-auto680):00042
+ (fig-forth-auto680):00043 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ (fig-forth-auto680):00044 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ (fig-forth-auto680):00045 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+ (fig-forth-auto680):00046 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ (fig-forth-auto680):00047 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+ (fig-forth-auto680):00048 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+ (fig-forth-auto680):00049 * THE SOFTWARE.
+ (fig-forth-auto680):00050 *
+ (fig-forth-auto680):00051 * "Associated documentation" for this declaration of license
+ (fig-forth-auto680):00052 * shall be interpreted to include only the comments in this file,
+ (fig-forth-auto680):00053 * or, if the code is split into multiple files,
+ (fig-forth-auto680):00054 * all files containing the complete source.
+ (fig-forth-auto680):00055 *
+ (fig-forth-auto680):00056 * This is the MIT model license, as published by the Open Source Consortium,
+ (fig-forth-auto680):00057 * with associated documentation defined.
+ (fig-forth-auto680):00058 * It was chosen to reflect the spirit of the original
+ (fig-forth-auto680):00059 * terms of use, which used archaic legal terminology.
+ (fig-forth-auto680):00060 *
+ (fig-forth-auto680):00061
+ (fig-forth-auto680):00062 * Authors of the 6800 model:
+ (fig-forth-auto680):00063 * === Primary: Dave Lion,
+ (fig-forth-auto680):00064 * === with help from
+ (fig-forth-auto680):00065 * === Bob Smith,
+ (fig-forth-auto680):00066 * === LaFarr Stuart,
+ (fig-forth-auto680):00067 * === The Forth Interest Group
+ (fig-forth-auto680):00068 * === PO Box 1105
+ (fig-forth-auto680):00069 * === San Carlos, CA 94070
+ (fig-forth-auto680):00070 * === and
+ (fig-forth-auto680):00071 * === Unbounded Computing
+ (fig-forth-auto680):00072 * === 1134-K Aster Ave.
+ (fig-forth-auto680):00073 * === Sunnyvale, CA 94086
+ (fig-forth-auto680):00074 *
+ 0002 (fig-forth-auto680):00075 NATWID EQU 2 ; bytes per natural integer/pointer
+ (fig-forth-auto680):00076 * The original version was developed on an AMI EVK 300 PROTO
+ (fig-forth-auto680):00077 * system using an ACIA for the I/O.
+ (fig-forth-auto680):00078 * This version is developed targeting the Tandy Color Computer.
+ (fig-forth-auto680):00079
+ (fig-forth-auto680):00080 * All terminal 1/0
+ (fig-forth-auto680):00081 * is done in three subroutines:
+ (fig-forth-auto680):00082 * PEMIT ( word # 182 )
+ (fig-forth-auto680):00083 * PKEY ( 183 )
+ (fig-forth-auto680):00084 * PQTERM ( 184 )
+ (fig-forth-auto680):00085 *
+ (fig-forth-auto680):00086 * The FORTH words for disc related I/O follow the model
+ (fig-forth-auto680):00087 * of the FORTH Interest Group, but have not yet been
+ (fig-forth-auto680):00088 * tested using a real disc.
+ (fig-forth-auto680):00089 *
+ (fig-forth-auto680):00090 * Addresses in the 6800 implementation reflect the fact that,
+ (fig-forth-auto680):00091 * on the development system, it was convenient to
+ (fig-forth-auto680):00092 * write-protect memory at hex 1000, and leave the first
+ (fig-forth-auto680):00093 * 4K bytes write-enabled. As a consequence, code from
+ (fig-forth-auto680):00094 * location $1000 to lable ZZZZ could be put in ROM.
+ (fig-forth-auto680):00095 * Minor deviations from the model were made in the
+ (fig-forth-auto680):00096 * initialization and words ?STACK and FORGET
+ (fig-forth-auto680):00097 * in order to do this.
+ (fig-forth-auto680):00098 * Those deviations will be altered in this
+ (fig-forth-auto680):00099 * implementation for the 6809 -- Color Computer.
+ (fig-forth-auto680):00100 *
+ (fig-forth-auto680):00101
+ (fig-forth-auto680):00102 *
+ 7FFF (fig-forth-auto680):00103 MEMT32 EQU $7FFF absolute end of all ram
+ 3FFF (fig-forth-auto680):00104 MEMT16 EQU $3FFF
+ 7FFF (fig-forth-auto680):00105 MEMTOP EQU MEMT32 ; tentative guess
+ FBCE (fig-forth-auto680):00106 ACIAC EQU $FBCE the ACIA control address and
+ FBCF (fig-forth-auto680):00107 ACIAD EQU ACIAC+1 data address for PROTO
+ (fig-forth-auto680):00108 PAGE
+ (fig-forth-auto680):00109 * MEMORY MAP for this 16K|32K system:
+ (fig-forth-auto680):00110 * ( delineated so that systems with 4k byte write-
+ (fig-forth-auto680):00111 * protected segments can write protect FORTH )
+ (fig-forth-auto680):00112 *
+ (fig-forth-auto680):00113 * addr. contents pointer init by
+ (fig-forth-auto680):00114 * **** ******************************* ******* ******
+ (fig-forth-auto680):00115 * 2nd through 4th per-user tables
+ (fig-forth-auto680):00116 * 4000|7D00
+ 0100 (fig-forth-auto680):00117 USERSZ EQU 256 ; (Addressable by DP)
+ 0001 (fig-forth-auto680):00118 USER16 EQU 1 ; We can change these for ROMPACK or 64K.
+ 0004 (fig-forth-auto680):00119 USER32 EQU 4
+ 0004 (fig-forth-auto680):00120 USERCT EQU USER32
+ 3F00 (fig-forth-auto680):00121 IUP16 EQU MEMT16+1-USER16*USERSZ
+ 7C00 (fig-forth-auto680):00122 IUP32 EQU MEMT32+1-USER32*USERSZ
+ 7C00 (fig-forth-auto680):00123 IUP EQU IUP32
+ 007C (fig-forth-auto680):00124 IUPDP EQU IUP/256
+ (fig-forth-auto680):00125 * user tables of variables
+ (fig-forth-auto680):00126 * registers & pointers for the virtual machine
+ (fig-forth-auto680):00127 * scratch area used by various words
+ (fig-forth-auto680):00128 * 3F00|7C00 <== UP (DICTPT)
+ (fig-forth-auto680):00129 * 3EFF|7BFF HI
+ (fig-forth-auto680):00130 * substitute for disc mass memory
+ 0003 (fig-forth-auto680):00131 RAMSCR EQU 3
+ 0400 (fig-forth-auto680):00132 SCRSZ EQU 1024
+ (fig-forth-auto680):00133 * 3300|7000 LO,MEMEND
+ 3300 (fig-forth-auto680):00134 RAMD16 EQU IUP16-RAMSCR*SCRSZ
+ 7000 (fig-forth-auto680):00135 RAMD32 EQU IUP32-RAMSCR*SCRSZ
+ 7000 (fig-forth-auto680):00136 RAMDSK EQU RAMD32
+ 3300 (fig-forth-auto680):00137 MEME16 EQU RAMD16
+ 7000 (fig-forth-auto680):00138 MEME32 EQU RAMD32
+ 7000 (fig-forth-auto680):00139 MEMEND EQU MEME32
+ (fig-forth-auto680):00140 * 32FF|6FFF
+ (fig-forth-auto680):00141 * 4 buffer sectors of VIRTUAL MEMORY
+ 0004 (fig-forth-auto680):00142 NBLK EQU 4 ; # of disc buffer blocks for virtual memory
+ (fig-forth-auto680):00143 * Should NBLK be SCRSZ/SECTSZ?
+ (fig-forth-auto680):00144 * each block is SECTSZ+SECTRL bytes in size,
+ (fig-forth-auto680):00145 * holding SECTSZ characters
+ 0100 (fig-forth-auto680):00146 SECTSZ EQU 256
+ 0008 (fig-forth-auto680):00147 SECTRL EQU 8
+ 0420 (fig-forth-auto680):00148 BUFSZ EQU (SECTSZ+SECTRL)*NBLK
+ (fig-forth-auto680):00149 * 2EE0|6BE0 FIRST
+ 2EE0 (fig-forth-auto680):00150 BUFB16 EQU MEME16-BUFSZ
+ 6BE0 (fig-forth-auto680):00151 BUFB32 EQU MEME32-BUFSZ
+ 6BE0 (fig-forth-auto680):00152 BUFBAS EQU BUFB32
+ (fig-forth-auto680):00153 * "end" of "usable ram" -- in 16K
+ (fig-forth-auto680):00154 * 2EE0|6BE0 <== RP RINIT
+ 2EE0 (fig-forth-auto680):00155 IRP16 EQU BUFB16
+ 6BE0 (fig-forth-auto680):00156 IRP32 EQU BUFB32
+ 6BE0 (fig-forth-auto680):00157 IRP EQU IRP32
+ (fig-forth-auto680):00158 * RETURN STACK
+ (fig-forth-auto680):00159 * (64|112 levels nesting)
+ 0080 (fig-forth-auto680):00160 RSTK16 EQU 128
+ 00E0 (fig-forth-auto680):00161 RSTK32 EQU 224
+ (fig-forth-auto680):00162 * (2E60|6B00)
+ 2E60 (fig-forth-auto680):00163 SFTB16 EQU IRP16-RSTK16
+ 6B00 (fig-forth-auto680):00164 SFTB32 EQU IRP32-RSTK32
+ 6B00 (fig-forth-auto680):00165 SFTBND EQU SFTB32
+ (fig-forth-auto680):00166 * INPUT LINE BUFFER
+ (fig-forth-auto680):00167 * holds up to 256 characters
+ (fig-forth-auto680):00168 * and is scanned upward by IN
+ (fig-forth-auto680):00169 * starting at TIB
+ 0100 (fig-forth-auto680):00170 TIBSZ EQU 256
+ (fig-forth-auto680):00171 * 2D60|6A00
+ 2D60 (fig-forth-auto680):00172 ITIB16 EQU SFTB16-TIBSZ
+ 6A00 (fig-forth-auto680):00173 ITIB32 EQU SFTB32-TIBSZ
+ 6A00 (fig-forth-auto680):00174 ITIB EQU ITIB32
+ (fig-forth-auto680):00175 * 2D60|6A00 <== IN TIB
+ 2D60 (fig-forth-auto680):00176 ISP16 EQU ITIB16
+ 6A00 (fig-forth-auto680):00177 ISP32 EQU ITIB32
+ 6A00 (fig-forth-auto680):00178 ISP EQU ISP32
+ (fig-forth-auto680):00179 * 2D60|6A00 <== SP SP0,SINIT
+ (fig-forth-auto680):00180 * DATA STACK
+ (fig-forth-auto680):00181 * | grows downward from 2A60|6A00
+ (fig-forth-auto680):00182 * v
+ (fig-forth-auto680):00183 * - -
+ (fig-forth-auto680):00184 * |
+ (fig-forth-auto680):00185 * I DICTIONARY grows upward
+ (fig-forth-auto680):00186 *
+ (fig-forth-auto680):00187 * ???? end of ram-dictionary. <== DICTPT DPINIT
+ (fig-forth-auto680):00188 * "TASK"
+ (fig-forth-auto680):00189 *
+ (fig-forth-auto680):00190 * ???? "FORTH" ( a word ) <=, <== CONTEXT
+ (fig-forth-auto680):00191 * `==== CURRENT
+ (fig-forth-auto680):00192 * start of ram-dictionary.
+ (fig-forth-auto680):00193 *
+ (fig-forth-auto680):00194 * >>>>>> memory from here up must be in RAM area <<<<<<
+ (fig-forth-auto680):00195 *
+ (fig-forth-auto680):00196 * ????
+ (fig-forth-auto680):00197 * 6k of romable "FORTH" <== IP ABORT
+ (fig-forth-auto680):00198 * <== W
+ (fig-forth-auto680):00199 * the VIRTUAL FORTH MACHINE
+ (fig-forth-auto680):00200 *
+ (fig-forth-auto680):00201 * 1208 initialization tables
+ (fig-forth-auto680):00202 * 1204 <<< WARM START ENTRY >>>
+ (fig-forth-auto680):00203 * 1200 <<< COLD START ENTRY >>>
+ (fig-forth-auto680):00204 * 1200 lowest address used by FORTH
+ (fig-forth-auto680):00205 *
+ 1200 (fig-forth-auto680):00206 CODEBG EQU $1200
+ (fig-forth-auto680):00207 * CODEBG EQU $3000
+ (fig-forth-auto680):00208 *
+ (fig-forth-auto680):00209 * >>>>>> memory from here down left alone <<<<<<
+ (fig-forth-auto680):00210 * >>>>>> so we can safely call ROM routines <<<<<<
+ (fig-forth-auto680):00211 *
+ (fig-forth-auto680):00212 * 0000
+ (fig-forth-auto680):00213 PAGE
+ (fig-forth-auto680):00214 ***
+ (fig-forth-auto680):00215 *
+ (fig-forth-auto680):00216 * CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
+ (fig-forth-auto680):00217 *
+ (fig-forth-auto680):00218 * IP (hardware Y) points to the current instruction ( pre-increment mode )
+ (fig-forth-auto680):00219 * RP (hardware S) points to last return address pushedin return stack
+ (fig-forth-auto680):00220 * SP (hardware U) points to last byte pushed in data stack
+ (fig-forth-auto680):00221 *
+ (fig-forth-auto680):00222 * Y must be IP when NEXT is entered (if using the inner loop).
+ (fig-forth-auto680):00223 *
+ (fig-forth-auto680):00224 * When A and B hold one 16 bit FORTH data word,
+ (fig-forth-auto680):00225 * A contains the high byte, B, the low byte.
+ (fig-forth-auto680):00226 *
+ (fig-forth-auto680):00227 * UP (hardware DP) is the base of per-task ("user") variables.
+ (fig-forth-auto680):00228 * (Be careful of the stray semantics of "user".)
+ (fig-forth-auto680):00229 *
+ (fig-forth-auto680):00230 * W (hardware X) is the pointer to the "code field" address of native CPU
+ (fig-forth-auto680):00231 * machine code to be executed for the definition of the dictionary word
+ (fig-forth-auto680):00232 * to be executed/currently executing.
+ (fig-forth-auto680):00233 * The following natural integer (word) begins any "parameter section"
+ (fig-forth-auto680):00234 * (body) -- similar to a "this" pointer, but not the same.
+ (fig-forth-auto680):00235 * It may be native CPU machine code, or it may be a global variable,
+ (fig-forth-auto680):00236 * or it may be a list of Forth definition words (addresses).
+ (fig-forth-auto680):00237 *
+ (fig-forth-auto680):00238 * ======
+ (fig-forth-auto680):00239 * This implementation uses the native subroutine architecture
+ (fig-forth-auto680):00240 * rather than a postponed-push call that the 6800 model VM uses
+ (fig-forth-auto680):00241 * to save code and time in leaf routines.
+ (fig-forth-auto680):00242 *
+ (fig-forth-auto680):00243 * This should allow directly calling many of the Forth words
+ (fig-forth-auto680):00244 * from assembly language code.
+ (fig-forth-auto680):00245 * (Be aware of the need for a valid W in some cases.)
+ (fig-forth-auto680):00246 * It won't allow mixing assembly language directly into Forth word lists.
+ (fig-forth-auto680):00247 * ======
+ (fig-forth-auto680):00248 *
+ (fig-forth-auto680):00249 * boolean flags:
+ (fig-forth-auto680):00250 * 0 is false, anything else is true.
+ (fig-forth-auto680):00251 * Most places in this model that set a boolean flag set true as 1.
+ (fig-forth-auto680):00252 * This is in contrast to many models that set a boolean flag as -1.
+ (fig-forth-auto680):00253 *
+ (fig-forth-auto680):00254 ***
+ (fig-forth-auto680):00255
+ (fig-forth-auto680):00256 PAGE
+ (fig-forth-auto680):00257 * This system is shown with one user (task),
+ (fig-forth-auto680):00258 * but additional users (tasks) may be added
+ (fig-forth-auto680):00259 * by allocating additional user tables:
+ (fig-forth-auto680):00260 *
+ (fig-forth-auto680):00261 ORG IUP
+7C00 (fig-forth-auto680):00262 UBASE RMB USERSZ
+7D00 (fig-forth-auto680):00263 UBASEX RMB USERSZ data table for extra users
+ (fig-forth-auto680):00264 *
+ (fig-forth-auto680):00265 * Some of this stuff gets initialized during
+ (fig-forth-auto680):00266 * COLD start and WARM start:
+ (fig-forth-auto680):00267 * [ names correspond to FORTH words of similar (no X) name ]
+ (fig-forth-auto680):00268 *
+ (fig-forth-auto680):00269 ORG IUP
+ 7C00 (fig-forth-auto680):00270 UORIG EQU *
+ (fig-forth-auto680):00271 * A few useful VM variables
+ (fig-forth-auto680):00272 * Will be removed when they are no longer needed.
+ (fig-forth-auto680):00273 * All are replaced by 6809 registers.
+ (fig-forth-auto680):00274
+7C00 (fig-forth-auto680):00275 N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
+ (fig-forth-auto680):00276 * SP@,SWAP,DOES>,COLD
+ (fig-forth-auto680):00277
+ (fig-forth-auto680):00278
+ (fig-forth-auto680):00279 * These locations are used by the TRACE routine :
+ (fig-forth-auto680):00280
+7C0A (fig-forth-auto680):00281 TRLIM RMB 1 the count for tracing without user intervention
+7C0B (fig-forth-auto680):00282 TRACEM RMB 1 non-zero = trace mode
+7C0C (fig-forth-auto680):00283 BRKPT RMB 2 the breakpoint address at which
+ (fig-forth-auto680):00284 * the program will go into trace mode
+7C0E (fig-forth-auto680):00285 VECT RMB 2 vector to machine code
+ (fig-forth-auto680):00286 * (only needed if the TRACE routine is resident)
+ (fig-forth-auto680):00287
+ (fig-forth-auto680):00288
+ (fig-forth-auto680):00289 * Registers used by the FORTH virtual machine:
+ (fig-forth-auto680):00290 * Starting at $OOFO:
+ (fig-forth-auto680):00291
+ (fig-forth-auto680):00292
+7C10 (fig-forth-auto680):00293 W RMB 2 the instruction register points to 6800 code
+ (fig-forth-auto680):00294 * This is not exactly accurate. Points to the definiton body,
+ (fig-forth-auto680):00295 * which is native CPU machine code when it is native CPU machine code.
+7C12 (fig-forth-auto680):00296 IP RMB 2 the instruction pointer points to pointer to 6800 code
+7C14 (fig-forth-auto680):00297 RP RMB 2 the return stack pointer
+7C16 (fig-forth-auto680):00298 UP RMB 2 the pointer to base of current user's 'USER' table
+ (fig-forth-auto680):00299 * ( altered during multi-tasking )
+ (fig-forth-auto680):00300 *
+ (fig-forth-auto680):00301 *UORIG RMB 6 3 reserved variables
+7C18 (fig-forth-auto680):00302 RMB 6 3 reserved variables
+7C1E (fig-forth-auto680):00303 XSPZER RMB 2 initial top of data stack for this user
+7C20 (fig-forth-auto680):00304 XRZERO RMB 2 initial top of return stack
+7C22 (fig-forth-auto680):00305 XTIB RMB 2 start of terminal input buffer
+7C24 (fig-forth-auto680):00306 XWIDTH RMB 2 name field width
+7C26 (fig-forth-auto680):00307 XWARN RMB 2 warning message mode (0 = no disc)
+7C28 (fig-forth-auto680):00308 XFENCE RMB 2 fence for FORGET
+7C2A (fig-forth-auto680):00309 XDICTP RMB 2 dictionary pointer
+7C2C (fig-forth-auto680):00310 XVOCL RMB 2 vocabulary linking
+7C2E (fig-forth-auto680):00311 XBLK RMB 2 disc block being accessed
+7C30 (fig-forth-auto680):00312 XIN RMB 2 scan pointer into the block
+7C32 (fig-forth-auto680):00313 XOUT RMB 2 cursor position
+7C34 (fig-forth-auto680):00314 XSCR RMB 2 disc screen being accessed ( O=terminal )
+7C36 (fig-forth-auto680):00315 XOFSET RMB 2 disc sector offset for multi-disc
+7C38 (fig-forth-auto680):00316 XCONT RMB 2 last word in primary search vocabulary
+7C3A (fig-forth-auto680):00317 XCURR RMB 2 last word in extensible vocabulary
+7C3C (fig-forth-auto680):00318 XSTATE RMB 2 flag for 'interpret' or 'compile' modes
+7C3E (fig-forth-auto680):00319 XBASE RMB 2 number base for I/O numeric conversion
+7C40 (fig-forth-auto680):00320 XDPL RMB 2 decimal point place
+7C42 (fig-forth-auto680):00321 XFLD RMB 2
+7C44 (fig-forth-auto680):00322 XCSP RMB 2 current stack position, for compile checks
+7C46 (fig-forth-auto680):00323 XRNUM RMB 2
+7C48 (fig-forth-auto680):00324 XHLD RMB 2
+7C4A (fig-forth-auto680):00325 XDELAY RMB 2 carriage return delay count
+7C4C (fig-forth-auto680):00326 XCOLUM RMB 2 carriage width
+7C4E (fig-forth-auto680):00327 IOSTAT RMB 2 last acia status from write/read
+7C50 (fig-forth-auto680):00328 RMB 2 ( 4 spares! )
+7C52 (fig-forth-auto680):00329 RMB 2
+7C54 (fig-forth-auto680):00330 RMB 2
+7C56 (fig-forth-auto680):00331 RMB 2
+ (fig-forth-auto680):00332
+ (fig-forth-auto680):00333
+ (fig-forth-auto680):00334
+ (fig-forth-auto680):00335
+ (fig-forth-auto680):00336 *
+ (fig-forth-auto680):00337 *
+ (fig-forth-auto680):00338 * end of user table, start of common system variables
+ (fig-forth-auto680):00339 *
+ (fig-forth-auto680):00340 *
+ (fig-forth-auto680):00341 *
+7C58 (fig-forth-auto680):00342 XUSE RMB 2
+7C5A (fig-forth-auto680):00343 XPREV RMB 2
+7C5C (fig-forth-auto680):00344 RMB 4 ( spares )
+ (fig-forth-auto680):00345
+ (fig-forth-auto680):00346 PAGE
+ (fig-forth-auto680):00347 * The FORTH program ( address $1200 to about $27FF ) will be written
+ (fig-forth-auto680):00348 * so that it can be in a ROM, or write-protected if desired,
+ (fig-forth-auto680):00349 * but right now we're just getting it running.
+ (fig-forth-auto680):00350 ORG CODEBG
+ (fig-forth-auto680):00351
+ (fig-forth-auto680):00352 * ######>> screen 3 <<
+ (fig-forth-auto680):00353 *
+ (fig-forth-auto680):00354 ***************************
+ (fig-forth-auto680):00355 ** C O L D E N T R Y **
+ (fig-forth-auto680):00356 ***************************
+1200 12 (fig-forth-auto680):00357 ORIG NOP
+ (fig-forth-auto680):00358 * JMP CENT
+1201 171029 (fig-forth-auto680):00359 LBSR CENT
+ (fig-forth-auto680):00360 ***************************
+ (fig-forth-auto680):00361 ** W A R M E N T R Y **
+ (fig-forth-auto680):00362 ***************************
+1204 12 (fig-forth-auto680):00363 NOP
+ (fig-forth-auto680):00364 * JMP WENT warm-start code, keeps current dictionary intact
+1205 171062 (fig-forth-auto680):00365 LBSR WENT warm-start code, keeps current dictionary intact
+ 7C (fig-forth-auto680):00366 SETDP IUPDP
+ (fig-forth-auto680):00367
+ (fig-forth-auto680):00368 *
+ (fig-forth-auto680):00369 ******* startup parmeters **************************
+ (fig-forth-auto680):00370 *
+1208 68090000 (fig-forth-auto680):00371 FDB $6809,0000 cpu & revision
+120C 0000 (fig-forth-auto680):00372 FDB 0 topmost word in FORTH vocabulary
+ (fig-forth-auto680):00373 * BACKSP FDB $7F backspace character for editing
+120E 0008 (fig-forth-auto680):00374 BACKSP FDB $08 backspace character for editing
+1210 7C00 (fig-forth-auto680):00375 UPINIT FDB UORIG initial user area
+ (fig-forth-auto680):00376 * UPINIT FDB UORIG initial user area
+1212 6A00 (fig-forth-auto680):00377 SINIT FDB ISP ; initial top of data stack
+ (fig-forth-auto680):00378 * SINIT FDB ORIG-$D0 initial top of data stack
+1214 6BE0 (fig-forth-auto680):00379 RINIT FDB IRP ; initial top of return stack
+ (fig-forth-auto680):00380 * RINIT FDB ORIG-2 initial top of return stack
+1216 6A00 (fig-forth-auto680):00381 FDB ITIB ; terminal input buffer
+ (fig-forth-auto680):00382 * FDB ORIG-$D0 terminal input buffer
+1218 001F (fig-forth-auto680):00383 FDB 31 initial name field width
+121A 0000 (fig-forth-auto680):00384 FDB 0 initial warning mode (0 = no disc)
+121C 2AD0 (fig-forth-auto680):00385 FENCIN FDB REND initial fence
+121E 2AD0 (fig-forth-auto680):00386 DPINIT FDB REND cold start value for DICTPT
+1220 2AA5 (fig-forth-auto680):00387 VOCINT FDB FORTH+4*NATWID
+1222 0084 (fig-forth-auto680):00388 COLINT FDB 132 initial terminal carriage width
+1224 0004 (fig-forth-auto680):00389 DELINT FDB 4 initial carriage return delay
+ (fig-forth-auto680):00390 ****************************************************
+ (fig-forth-auto680):00391 *
+ (fig-forth-auto680):00392 PAGE
+ (fig-forth-auto680):00393 *
+ (fig-forth-auto680):00394 * ######>> screen 13 <<
+ (fig-forth-auto680):00395 * These were of questionable use anyway,
+ (fig-forth-auto680):00396 * kept here now to satisfy the assembler and show hints.
+ (fig-forth-auto680):00397 * They're too much trouble to use with native subroutine call anyway.
+ (fig-forth-auto680):00398 * PULABX PULS A ; 24 cycles until 'NEXT'
+ (fig-forth-auto680):00399 * PULS B ;
+ (fig-forth-auto680):00400 * PULABX PULU A,B ; ?? cycles until 'NEXT'
+ (fig-forth-auto680):00401 * STABX STA 0,X 16 cycles until 'NEXT'
+ (fig-forth-auto680):00402 * STB 1,X
+ (fig-forth-auto680):00403 * STABX STD 0,X ; ?? cycles until 'NEXT'
+1226 2000 (fig-forth-auto680):00404 BRA NEXT
+ (fig-forth-auto680):00405 * GETX LDA 0,X 18 cycles until 'NEXT'
+ (fig-forth-auto680):00406 * LDB 1,X
+ (fig-forth-auto680):00407 * GETX LDD 0,X ?? cycles until 'NEXT'
+ (fig-forth-auto680):00408 * PUSHBA PSHS B ; 8 cycles until 'NEXT'
+ (fig-forth-auto680):00409 * PSHS A ;
+ (fig-forth-auto680):00410 * PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
+ (fig-forth-auto680):00411
+ (fig-forth-auto680):00412
+ (fig-forth-auto680):00413 *
+ (fig-forth-auto680):00414 * "NEXT" takes ?? cycles if TRACE is removed,
+ (fig-forth-auto680):00415 *
+ (fig-forth-auto680):00416 * and ?? cycles if trace is present and NOT tracing.
+ (fig-forth-auto680):00417 *
+ (fig-forth-auto680):00418 * = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
+ (fig-forth-auto680):00419 * =
+ (fig-forth-auto680):00420 * NEXT itself might just completely go away.
+ (fig-forth-auto680):00421 * About the only reason to keep it is to allowing executing a list
+ (fig-forth-auto680):00422 * which allows a cheap TRACE routine.
+ (fig-forth-auto680):00423 *
+ (fig-forth-auto680):00424 * NEXT is a loop which implements the Forth VM.
+ (fig-forth-auto680):00425 * It basically cycles through calling the code out of code lists,
+ (fig-forth-auto680):00426 * one at a time.
+ (fig-forth-auto680):00427 * Using a native CPU return for this uses a few extra cycles per call,
+ (fig-forth-auto680):00428 * compared to simply jumping to each definition and jumping back
+ (fig-forth-auto680):00429 * to the known beginning of the loop,
+ (fig-forth-auto680):00430 * but the loop itself is really only there for convenience.
+ (fig-forth-auto680):00431 *
+ (fig-forth-auto680):00432 * This implementation uses the native subroutine call,
+ (fig-forth-auto680):00433 * to break the wall between Forth code and non-Forth code.
+ (fig-forth-auto680):00434 *
+ (fig-forth-auto680):00435 * NEXT LDX IP
+ (fig-forth-auto680):00436 * LEAX 1,X ; pre-increment mode
+ (fig-forth-auto680):00437 * LEAX 1,X ;
+ (fig-forth-auto680):00438 * STX IP
+1228 (fig-forth-auto680):00439 NEXT ; IP is Y, push before using, pull before you come back here.
+ (fig-forth-auto680):00440 *
+ (fig-forth-auto680):00441 * NEXT2 LDX 0,X get W which points to CFA of word to be done
+1228 AEA1 (fig-forth-auto680):00442 NEXT2 LDX ,Y++ get W which points to CFA of word to be done
+122A 8D08 (fig-forth-auto680):00443 BSR DBGNAM
+122C 8D58 (fig-forth-auto680):00444 BSR DBGREG
+ (fig-forth-auto680):00445 * But NEXT2 is too much trouble to use with subroutine threading anyway.
+ (fig-forth-auto680):00446 * NEXT3 STX W
+122E (fig-forth-auto680):00447 NEXT3 ; W is X until you use X for something else. (TOS points back here.)
+ (fig-forth-auto680):00448 * But NEXT3 is too much trouble to use with subroutine threading anyway.
+ (fig-forth-auto680):00449 * LDX 0,X get VECT which points to executable code
+ (fig-forth-auto680):00450 * =
+ (fig-forth-auto680):00451 * The next instruction could be patched to JMP TRACE =
+ (fig-forth-auto680):00452 * if a TRACE routine is available: =
+ (fig-forth-auto680):00453 * =
+ (fig-forth-auto680):00454 * JMP 0,X
+ (fig-forth-auto680):00455
+122E AD94 (fig-forth-auto680):00456 JSR [,X] ; Saving the postinc cycles,
+ (fig-forth-auto680):00457 * ; but X must be bumped NATWID to the parameters.
+ (fig-forth-auto680):00458 * NOP
+ (fig-forth-auto680):00459 * JMP TRACE ( an alternate for the above )
+1230 8D54 (fig-forth-auto680):00460 BSR DBGREG ( an alternate for the above )
+ (fig-forth-auto680):00461 * In other words, with the call and the NOP,
+ (fig-forth-auto680):00462 * there is room to patch the call with a JMP to your TRACE
+ (fig-forth-auto680):00463 * routine, which you have to provide.
+1232 20F4 (fig-forth-auto680):00464 BRA NEXT
+ (fig-forth-auto680):00465 *
+1234 3437 (fig-forth-auto680):00466 DBGNAM PSHS CC,D,X,Y
+1236 0D0B (fig-forth-auto680):00467 TST <TRACEM
+1238 2724 (fig-forth-auto680):00468 BEQ DBGNrt
+123A 301D (fig-forth-auto680):00469 LEAX -3,X
+123C E682 (fig-forth-auto680):00470 DBGNlf LDB ,-X
+123E 2AFC (fig-forth-auto680):00471 BPL DBGNlf
+1240 108E04C0 (fig-forth-auto680):00472 LDY #$4C0
+1244 E680 (fig-forth-auto680):00473 LDB ,X+
+1246 E680 (fig-forth-auto680):00474 DBGNlp LDB ,X+
+1248 2B04 (fig-forth-auto680):00475 BMI DBGNll
+124A E7A0 (fig-forth-auto680):00476 STB ,Y+
+124C 20F8 (fig-forth-auto680):00477 BRA DBGNlp
+124E C47F (fig-forth-auto680):00478 DBGNll ANDB #$7F
+1250 E7A0 (fig-forth-auto680):00479 STB ,Y+
+1252 C660 (fig-forth-auto680):00480 LDB #$60
+1254 2002 (fig-forth-auto680):00481 BRA DBGNlt
+1256 E7A0 (fig-forth-auto680):00482 DBGNlc STB ,Y+
+1258 108C04E0 (fig-forth-auto680):00483 DBGNlt CMPY #$4E0
+125C 25F8 (fig-forth-auto680):00484 BLO DBGNlc
+125E 35B7 (fig-forth-auto680):00485 DBGNrt PULS CC,D,X,Y,PC
+ (fig-forth-auto680):00486 *
+ (fig-forth-auto680):00487 *
+1260 54 (fig-forth-auto680):00488 MKhxBh LSRB
+1261 54 (fig-forth-auto680):00489 LSRB
+1262 54 (fig-forth-auto680):00490 LSRB
+1263 54 (fig-forth-auto680):00491 LSRB
+1264 C40F (fig-forth-auto680):00492 MKhxBl ANDB #$0F
+1266 CB30 (fig-forth-auto680):00493 ADDB #$30
+1268 C139 (fig-forth-auto680):00494 CMPB #$39
+126A 2302 (fig-forth-auto680):00495 BLS MKhxBx
+126C CBC7 (fig-forth-auto680):00496 ADDB #$C7 ; ($40-$39)-$40
+126E 39 (fig-forth-auto680):00497 MKhxBx RTS
+ (fig-forth-auto680):00498 *
+126F 1E89 (fig-forth-auto680):00499 OUThxA EXG A,B
+1271 8D05 (fig-forth-auto680):00500 BSR OUThxB
+1273 1E89 (fig-forth-auto680):00501 EXG A,B
+1275 39 (fig-forth-auto680):00502 RTS
+ (fig-forth-auto680):00503 *
+1276 8DF7 (fig-forth-auto680):00504 OUThxD BSR OUThxA
+1278 3404 (fig-forth-auto680):00505 OUThxB PSHS B
+127A 8DE4 (fig-forth-auto680):00506 BSR MKhxBh
+127C E780 (fig-forth-auto680):00507 STB ,X+
+127E E6E4 (fig-forth-auto680):00508 LDB ,S
+1280 8DE2 (fig-forth-auto680):00509 BSR MKhxBl
+1282 E780 (fig-forth-auto680):00510 STB ,X+
+1284 3584 (fig-forth-auto680):00511 PULS B,PC
+ (fig-forth-auto680):00512 *
+1286 347F (fig-forth-auto680):00513 DBGREG PSHS U,Y,X,DP,B,A,CC
+1288 0D0B (fig-forth-auto680):00514 TST <TRACEM
+128A 102700DF (fig-forth-auto680):00515 LBEQ DBGRrt
+128E 318D00DD (fig-forth-auto680):00516 LEAY DBGRLB,PCR
+1292 8E04E0 (fig-forth-auto680):00517 LDX #$4E0
+1295 ECA1 (fig-forth-auto680):00518 DBGRlp LDD ,Y++
+1297 2704 (fig-forth-auto680):00519 BEQ DBGRdn
+1299 ED81 (fig-forth-auto680):00520 STD ,X++
+129B 20F8 (fig-forth-auto680):00521 BRA DBGRlp
+129D 8E0500 (fig-forth-auto680):00522 DBGRdn LDX #$500
+12A0 A663 (fig-forth-auto680):00523 LDA 3,S ; DP
+12A2 E6E4 (fig-forth-auto680):00524 LDB ,S ; CC
+12A4 8DD0 (fig-forth-auto680):00525 BSR OUThxD
+12A6 C660 (fig-forth-auto680):00526 LDB #$60
+12A8 E780 (fig-forth-auto680):00527 STB ,X+
+12AA EC6A (fig-forth-auto680):00528 LDD 3*NATWID+4,S ; PC:505
+12AC 8DC8 (fig-forth-auto680):00529 BSR OUThxD
+12AE C660 (fig-forth-auto680):00530 LDB #$60
+12B0 E780 (fig-forth-auto680):00531 STB ,X+
+12B2 1F40 (fig-forth-auto680):00532 TFR S,D ; 509
+12B4 C3000C (fig-forth-auto680):00533 ADDD #4*NATWID+4
+12B7 8DBD (fig-forth-auto680):00534 BSR OUThxD
+12B9 EC68 (fig-forth-auto680):00535 LDD 2*NATWID+4,S ; U:50E
+12BB 8DB9 (fig-forth-auto680):00536 BSR OUThxD
+12BD C660 (fig-forth-auto680):00537 LDB #$60
+12BF E780 (fig-forth-auto680):00538 STB ,X+
+12C1 EC66 (fig-forth-auto680):00539 LDD 1*NATWID+4,S ; Y:513
+12C3 8DB1 (fig-forth-auto680):00540 BSR OUThxD
+12C5 EC64 (fig-forth-auto680):00541 LDD 0*NATWID+4,S ; X at 517
+12C7 8DAD (fig-forth-auto680):00542 BSR OUThxD
+12C9 C660 (fig-forth-auto680):00543 LDB #$60
+12CB E780 (fig-forth-auto680):00544 STB ,X+
+12CD EC61 (fig-forth-auto680):00545 LDD 1,S ; D at 51C
+12CF 8DA5 (fig-forth-auto680):00546 BSR OUThxD
+12D1 C660 (fig-forth-auto680):00547 LDB #$60
+12D3 E780 (fig-forth-auto680):00548 STB ,X+
+12D5 E780 (fig-forth-auto680):00549 STB ,X+
+12D7 E780 (fig-forth-auto680):00550 STB ,X+
+12D9 E780 (fig-forth-auto680):00551 STB ,X+
+12DB E780 (fig-forth-auto680):00552 STB ,X+
+12DD ECF80A (fig-forth-auto680):00553 LDD [3*NATWID+4,S] ; PC
+12E0 8D94 (fig-forth-auto680):00554 BSR OUThxD
+12E2 C660 (fig-forth-auto680):00555 LDB #$60
+12E4 E780 (fig-forth-auto680):00556 STB ,X+
+12E6 EC6C (fig-forth-auto680):00557 LDD 4*NATWID+4,S ; S
+12E8 8D8C (fig-forth-auto680):00558 BSR OUThxD
+12EA ECF808 (fig-forth-auto680):00559 LDD [2*NATWID+4,S] ; U
+12ED 8D87 (fig-forth-auto680):00560 BSR OUThxD
+12EF C660 (fig-forth-auto680):00561 LDB #$60
+12F1 E780 (fig-forth-auto680):00562 STB ,X+
+12F3 ECF806 (fig-forth-auto680):00563 LDD [1*NATWID+4,S] ; Y
+12F6 17FF7D (fig-forth-auto680):00564 LBSR OUThxD
+12F9 ECF804 (fig-forth-auto680):00565 LDD [0*NATWID+4,S] ; X
+12FC 17FF77 (fig-forth-auto680):00566 LBSR OUThxD
+12FF C660 (fig-forth-auto680):00567 LDB #$60
+1301 E780 (fig-forth-auto680):00568 STB ,X+
+1303 E780 (fig-forth-auto680):00569 STB ,X+
+1305 E780 (fig-forth-auto680):00570 STB ,X+
+1307 E780 (fig-forth-auto680):00571 STB ,X+
+1309 E780 (fig-forth-auto680):00572 STB ,X+
+130B C600 (fig-forth-auto680):00573 LDB #0
+130D 1E9B (fig-forth-auto680):00574 EXG B,DP
+130F AD9FA000 (fig-forth-auto680):00575 DBGRkl JSR [$A000]
+1313 27FA (fig-forth-auto680):00576 BEQ DBGRkl
+1315 FD043E (fig-forth-auto680):00577 STD $43E
+1318 1EB9 (fig-forth-auto680):00578 EXG DP,B
+131A 8155 (fig-forth-auto680):00579 CMPA #$55 ; 'U'
+131C 273C (fig-forth-auto680):00580 BEQ DBGRdU
+131E 8153 (fig-forth-auto680):00581 CMPA #$53 ; 'S'
+1320 271E (fig-forth-auto680):00582 BEQ DBGRdS
+1322 8149 (fig-forth-auto680):00583 CMPA #$49 ; 'I'
+1324 2647 (fig-forth-auto680):00584 BNE DBGRrt
+1326 DC22 (fig-forth-auto680):00585 DBGRin LDD <XTIB
+1328 D330 (fig-forth-auto680):00586 ADDD <XIN
+132A 1F02 (fig-forth-auto680):00587 TFR D,Y
+132C 17FF47 (fig-forth-auto680):00588 LBSR OUThxD
+132F C63A (fig-forth-auto680):00589 LDB #$3a ; ':'
+1331 E780 (fig-forth-auto680):00590 STB ,X+
+1333 964C (fig-forth-auto680):00591 LDA <XCOLUM
+1335 E6A0 (fig-forth-auto680):00592 DBGRip LDB ,Y+
+1337 E780 (fig-forth-auto680):00593 STB ,X+
+1339 2732 (fig-forth-auto680):00594 BEQ DBGRrt
+133B 4A (fig-forth-auto680):00595 DBGRit DECA
+133C 26F7 (fig-forth-auto680):00596 BNE DBGRip
+133E 202D (fig-forth-auto680):00597 BRA DBGRrt
+1340 1F42 (fig-forth-auto680):00598 DBGRdS TFR S,Y
+1342 2009 (fig-forth-auto680):00599 BRA DBGRst
+1344 ECA1 (fig-forth-auto680):00600 DBGRsp LDD ,Y++
+1346 17FF2D (fig-forth-auto680):00601 LBSR OUThxD
+1349 C660 (fig-forth-auto680):00602 LDB #$60
+134B E780 (fig-forth-auto680):00603 STB ,X+
+134D 109C20 (fig-forth-auto680):00604 DBGRst CMPY <XRZERO
+1350 25F2 (fig-forth-auto680):00605 BLO DBGRsp
+1352 C63A (fig-forth-auto680):00606 LDB #$3a ; ':'
+1354 E780 (fig-forth-auto680):00607 STB ,X+
+1356 C655 (fig-forth-auto680):00608 LDB #$55
+1358 E780 (fig-forth-auto680):00609 STB ,X+
+135A 10AE68 (fig-forth-auto680):00610 DBGRdU LDY 2*NATWID+4,S
+135D 2009 (fig-forth-auto680):00611 BRA DBGRut
+135F ECA1 (fig-forth-auto680):00612 DBGRup LDD ,Y++
+1361 17FF12 (fig-forth-auto680):00613 LBSR OUThxD
+1364 C660 (fig-forth-auto680):00614 LDB #$60
+1366 E780 (fig-forth-auto680):00615 STB ,X+
+1368 109C1E (fig-forth-auto680):00616 DBGRut CMPY <XSPZER
+136B 25F2 (fig-forth-auto680):00617 BLO DBGRup
+136D 35FF (fig-forth-auto680):00618 DBGRrt PULS CC,A,B,DP,X,Y,U,PC
+136F 4450434320504320 (fig-forth-auto680):00619 DBGRLB FCC 'DPCC PC S U Y X A B '
+ 2020532020205520
+ 2020205920202058
+ 2020202041204220
+138F 00000000 (fig-forth-auto680):00620 FDB 0,0
+ (fig-forth-auto680):00621
+ (fig-forth-auto680):00622
+ (fig-forth-auto680):00623 *
+ (fig-forth-auto680):00624 * =
+ (fig-forth-auto680):00625 * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+ (fig-forth-auto680):00626
+ (fig-forth-auto680):00627
+ (fig-forth-auto680):00628 PAGE
+ (fig-forth-auto680):00629 *
+ (fig-forth-auto680):00630 * ======>> 1 <<
+ (fig-forth-auto680):00631 * ( --- n )
+ (fig-forth-auto680):00632 * Pushes the following natural width integer from the instruction stream
+ (fig-forth-auto680):00633 * as a literal, or immediate value.
+ (fig-forth-auto680):00634 *
+ (fig-forth-auto680):00635 * FDB {OP}
+ (fig-forth-auto680):00636 * FDB {OP}
+ (fig-forth-auto680):00637 * FDB LIT
+ (fig-forth-auto680):00638 * FDB LITERAL-TO-BE-PUSHED
+ (fig-forth-auto680):00639 * FDB {OP}
+ (fig-forth-auto680):00640 *
+ (fig-forth-auto680):00641 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00642 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00643 * (Note that there is no compile-only flag in the fig model.)
+ (fig-forth-auto680):00644 *
+ (fig-forth-auto680):00645 * See (FIND), or PFIND , for layout of the header format.
+ (fig-forth-auto680):00646 *
+1393 83 (fig-forth-auto680):00647 FCB $83
+1394 4C49 (fig-forth-auto680):00648 FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
+1396 D4 (fig-forth-auto680):00649 FCB $D4 ; 'T'|'\x80' ; character code for T, with high bit set.
+1397 0000 (fig-forth-auto680):00650 FDB 0 ; link of zero to terminate dictionary scan
+1399 139B (fig-forth-auto680):00651 LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
+139B ECA1 (fig-forth-auto680):00652 LDD ,Y++
+139D 3606 (fig-forth-auto680):00653 PSHU A,B
+139F 39 (fig-forth-auto680):00654 RTS
+ (fig-forth-auto680):00655 * LDX IP
+ (fig-forth-auto680):00656 * LEAX 1,X ;
+ (fig-forth-auto680):00657 * LEAX 1,X ;
+ (fig-forth-auto680):00658 * STX IP
+ (fig-forth-auto680):00659 * LDA 0,X
+ (fig-forth-auto680):00660 * LDB 1,X
+ (fig-forth-auto680):00661 * JMP PUSHBA
+ (fig-forth-auto680):00662 *
+ (fig-forth-auto680):00663 * ######>> screen 14 <<
+ (fig-forth-auto680):00664 * ======>> 2 <<
+ (fig-forth-auto680):00665 * ( --- n )
+ (fig-forth-auto680):00666 * Pushes the following byte from the instruction stream
+ (fig-forth-auto680):00667 * as a literal, or immediate value.
+ (fig-forth-auto680):00668 *
+ (fig-forth-auto680):00669 * FDB {OP}
+ (fig-forth-auto680):00670 * FDB {OP}
+ (fig-forth-auto680):00671 * FDB LIT8
+ (fig-forth-auto680):00672 * FCB LITERAL-TO-BE-PUSHED
+ (fig-forth-auto680):00673 * FDB {OP}
+ (fig-forth-auto680):00674 *
+ (fig-forth-auto680):00675 * If this is kept, it should have a header for TRACE to read.
+ (fig-forth-auto680):00676 * If the data bus is wider than a byte, you don't want to do this.
+ (fig-forth-auto680):00677 * Byte shaving like this is often counter-productive anyway.
+ (fig-forth-auto680):00678 * Changing the name to LIT8, hoping that will be more understandable.
+ (fig-forth-auto680):00679 * Also, see comments for LIT.
+ (fig-forth-auto680):00680 * (Note that there is no compile-only flag in the fig model.)
+13A0 84 (fig-forth-auto680):00681 FCB $84
+13A1 4C4954 (fig-forth-auto680):00682 FCC 'LIT' ; 'LIT8' : NOTE: this is different from LITERAL
+13A4 B8 (fig-forth-auto680):00683 FCB $B8
+13A5 1393 (fig-forth-auto680):00684 FDB LIT-6
+13A7 13A9 (fig-forth-auto680):00685 LIT8 FDB *+NATWID (this was an invisible word, with no header)
+13A9 E6A0 (fig-forth-auto680):00686 LDB ,Y+ ; This also is meaningless in native code.
+13AB 4F (fig-forth-auto680):00687 CLRA
+13AC 3606 (fig-forth-auto680):00688 PSHU A,B
+13AE 39 (fig-forth-auto680):00689 RTS
+ (fig-forth-auto680):00690 * LDX IP
+ (fig-forth-auto680):00691 * LEAX 1,X ;
+ (fig-forth-auto680):00692 * STX IP
+ (fig-forth-auto680):00693 * CLRA ;
+ (fig-forth-auto680):00694 * LDB 1,X
+ (fig-forth-auto680):00695 * JMP PUSHBA
+ (fig-forth-auto680):00696 *
+ (fig-forth-auto680):00697 * ( n off --- n )
+ (fig-forth-auto680):00698 * off is offset in video buffer area.
+13AF 87 (fig-forth-auto680):00699 FCB $87
+13B0 53484F57544F (fig-forth-auto680):00700 FCC 'SHOWTO' ; 'SHOWTOS'
+13B6 D3 (fig-forth-auto680):00701 FCB $D3 ; 'S'
+13B7 13A0 (fig-forth-auto680):00702 FDB LIT8-7
+13B9 13BB (fig-forth-auto680):00703 SHOTOS FDB *+NATWID
+13BB 8E0400 (fig-forth-auto680):00704 LDX #$400
+13BE ECC1 (fig-forth-auto680):00705 LDD ,U++
+13C0 308B (fig-forth-auto680):00706 LEAX D,X
+13C2 ECC4 (fig-forth-auto680):00707 LDD ,U
+13C4 17FEAF (fig-forth-auto680):00708 LBSR OUThxD
+13C7 39 (fig-forth-auto680):00709 RTS
+ (fig-forth-auto680):00710 *
+13C8 85 (fig-forth-auto680):00711 FCB $85
+13C9 54524F46 (fig-forth-auto680):00712 FCC 'TROF' ; 'TROFF'
+13CD C6 (fig-forth-auto680):00713 FCB $C6 ; 'F'|$80
+13CE 13AF (fig-forth-auto680):00714 FDB SHOTOS-10
+13D0 13D2 (fig-forth-auto680):00715 TROFF FDB *+NATWID
+13D2 0F0B (fig-forth-auto680):00716 CLR <TRACEM
+13D4 39 (fig-forth-auto680):00717 RTS
+ (fig-forth-auto680):00718 *
+13D5 84 (fig-forth-auto680):00719 FCB $84
+13D6 54524F (fig-forth-auto680):00720 FCC 'TRO' ; 'TRON'
+13D9 CE (fig-forth-auto680):00721 FCB $CE ; 'N'|$80
+13DA 13C8 (fig-forth-auto680):00722 FDB TROFF-8
+13DC 13DE (fig-forth-auto680):00723 TRON FDB *+NATWID
+13DE 0C0B (fig-forth-auto680):00724 INC <TRACEM
+13E0 39 (fig-forth-auto680):00725 RTS
+ (fig-forth-auto680):00726 *
+ (fig-forth-auto680):00727 * ======>> 3 <<
+ (fig-forth-auto680):00728 * ( adr --- )
+ (fig-forth-auto680):00729 * Jump to address on stack. Used by the "outer" interpreter to
+ (fig-forth-auto680):00730 * interactively invoke routines.
+ (fig-forth-auto680):00731 * Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
+13E1 87 (fig-forth-auto680):00732 FCB $87
+13E2 455845435554 (fig-forth-auto680):00733 FCC 'EXECUT' ; 'EXECUTE'
+13E8 C5 (fig-forth-auto680):00734 FCB $C5
+13E9 13D5 (fig-forth-auto680):00735 FDB TRON-7
+13EB 13ED (fig-forth-auto680):00736 EXEC FDB *+NATWID
+13ED 3710 (fig-forth-auto680):00737 PULU X ; Gotta have W anyway, just in case.
+13EF 6E94 (fig-forth-auto680):00738 JMP [,X] ; Tail return.
+ (fig-forth-auto680):00739 * TFR S,X ; TSX :
+ (fig-forth-auto680):00740 * LDX 0,X get code field address (CFA)
+ (fig-forth-auto680):00741 * LEAS 1,S ; pop stack
+ (fig-forth-auto680):00742 * LEAS 1,S ;
+ (fig-forth-auto680):00743 * JMP NEXT3
+ (fig-forth-auto680):00744 *
+ (fig-forth-auto680):00745 * ######>> screen 15 <<
+ (fig-forth-auto680):00746 * ======>> 4 <<
+ (fig-forth-auto680):00747 * ( --- ) C
+ (fig-forth-auto680):00748 * Add the following word from the instruction stream to the
+ (fig-forth-auto680):00749 * instruction pointer (Y++). Causes a program branch in Forth code stream.
+ (fig-forth-auto680):00750 *
+ (fig-forth-auto680):00751 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00752 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00753 * This is only for Forth code stream.
+ (fig-forth-auto680):00754 * Also, see comments for LIT.
+13F1 86 (fig-forth-auto680):00755 FCB $86
+13F2 4252414E43 (fig-forth-auto680):00756 FCC 'BRANC' ; 'BRANCH'
+13F7 C8 (fig-forth-auto680):00757 FCB $C8
+13F8 13E1 (fig-forth-auto680):00758 FDB EXEC-10
+13FA 140F (fig-forth-auto680):00759 BRAN FDB ZBYES ; Go steal code in ZBRANCH
+ (fig-forth-auto680):00760
+ (fig-forth-auto680):00761 * Moving code around to optimize the branch taking case in 0BRANCH.
+13FC 3122 (fig-forth-auto680):00762 ZBNO LEAY NATWID,Y ; No branch.
+13FE 39 (fig-forth-auto680):00763 RTS
+ (fig-forth-auto680):00764 * ======>> 5 <<
+ (fig-forth-auto680):00765 * ( f --- ) C
+ (fig-forth-auto680):00766 * BRANCH if flag is zero.
+ (fig-forth-auto680):00767 *
+ (fig-forth-auto680):00768 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00769 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00770 * This is only for Forth code stream.
+ (fig-forth-auto680):00771 * Also, see comments for LIT.
+13FF 87 (fig-forth-auto680):00772 FCB $87
+1400 304252414E43 (fig-forth-auto680):00773 FCC '0BRANC' ; '0BRANCH'
+1406 C8 (fig-forth-auto680):00774 FCB $C8
+1407 13F1 (fig-forth-auto680):00775 FDB BRAN-9
+1409 140B (fig-forth-auto680):00776 ZBRAN FDB *+NATWID
+140B ECC1 (fig-forth-auto680):00777 LDD ,U++
+140D 26ED (fig-forth-auto680):00778 BNE ZBNO
+140F ECA1 (fig-forth-auto680):00779 ZBYES LDD ,Y++
+1411 31AB (fig-forth-auto680):00780 LEAY D,Y ; IP is postinc
+1413 39 (fig-forth-auto680):00781 RTS
+ (fig-forth-auto680):00782 * PULS A ;
+ (fig-forth-auto680):00783 * PULS B ;
+ (fig-forth-auto680):00784 * PSHS B ; ** emulating ABA:
+ (fig-forth-auto680):00785 * ADDA ,S+ ;
+ (fig-forth-auto680):00786 * BNE ZBNO
+ (fig-forth-auto680):00787 * BCS ZBNO
+ (fig-forth-auto680):00788 * ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
+ (fig-forth-auto680):00789 * LDB 3,X
+ (fig-forth-auto680):00790 * LDA 2,X
+ (fig-forth-auto680):00791 * ADDB IP+1
+ (fig-forth-auto680):00792 * ADCA IP
+ (fig-forth-auto680):00793 * STB IP+1
+ (fig-forth-auto680):00794 * STA IP
+ (fig-forth-auto680):00795 * JMP NEXT
+ (fig-forth-auto680):00796 * ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
+ (fig-forth-auto680):00797 * LEAX 1,X ; jump over branch delta
+ (fig-forth-auto680):00798 * LEAX 1,X ;
+ (fig-forth-auto680):00799 * STX IP
+ (fig-forth-auto680):00800 * JMP NEXT
+ (fig-forth-auto680):00801 *
+ (fig-forth-auto680):00802 * ######>> screen 16 <<
+ (fig-forth-auto680):00803 * ======>> 6 <<
+ (fig-forth-auto680):00804 * ( --- ) ( limit index *** limit index+1) C
+ (fig-forth-auto680):00805 * ( limit index *** )
+ (fig-forth-auto680):00806 * Counting loop primitive. The counter and limit are the top two
+ (fig-forth-auto680):00807 * words on the return stack. If the updated index/counter does
+ (fig-forth-auto680):00808 * not exceed the limit, a branch occurs. If it does, the branch
+ (fig-forth-auto680):00809 * does not occur, and the index and limit are dropped from the
+ (fig-forth-auto680):00810 * return stack.
+ (fig-forth-auto680):00811 *
+ (fig-forth-auto680):00812 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00813 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00814 * This is only for Forth code stream.
+ (fig-forth-auto680):00815 * Also, see comments for LIT.
+1414 86 (fig-forth-auto680):00816 FCB $86
+1415 284C4F4F50 (fig-forth-auto680):00817 FCC '(LOOP' ; '(LOOP)'
+141A A9 (fig-forth-auto680):00818 FCB $A9
+141B 13FF (fig-forth-auto680):00819 FDB ZBRAN-10
+141D 141F (fig-forth-auto680):00820 XLOOP FDB *+NATWID
+141F CC0001 (fig-forth-auto680):00821 LDD #1 ; Borrowing from BIF-6809.
+1422 E362 (fig-forth-auto680):00822 XLOOPA ADDD NATWID,S ; Dodge the return address.
+1424 ED62 (fig-forth-auto680):00823 STD NATWID,S
+1426 A364 (fig-forth-auto680):00824 SUBD 2*NATWID,S
+1428 2DE5 (fig-forth-auto680):00825 BLT ZBYES ; signed
+142A 3122 (fig-forth-auto680):00826 XLOOPN LEAY NATWID,Y
+142C AEE4 (fig-forth-auto680):00827 LDX ,S ; synthetic return
+142E 3266 (fig-forth-auto680):00828 LEAS 3*NATWID,S ; Clean up the index and limit.
+1430 6E84 (fig-forth-auto680):00829 JMP ,X
+ (fig-forth-auto680):00830 * CLRA ;
+ (fig-forth-auto680):00831 * LDB #1 get set to increment counter by 1 (Clears N.)
+ (fig-forth-auto680):00832 * BRA XPLOP2 go steal other guy's code!
+ (fig-forth-auto680):00833 *
+ (fig-forth-auto680):00834 * ======>> 7 <<
+ (fig-forth-auto680):00835 * ( n --- ) ( limit index *** limit index+n ) C
+ (fig-forth-auto680):00836 * ( limit index *** )
+ (fig-forth-auto680):00837 * Loop with a variable increment. Terminates when the index
+ (fig-forth-auto680):00838 * crosses the boundary from one below the limit to the limit. A
+ (fig-forth-auto680):00839 * positive n will cause termination if the result index equals the
+ (fig-forth-auto680):00840 * limit. A negative n must cause the index to become less than
+ (fig-forth-auto680):00841 * the limit to cause loop termination.
+ (fig-forth-auto680):00842 *
+ (fig-forth-auto680):00843 * Note that the end conditions are not symmetric around zero.
+ (fig-forth-auto680):00844 *
+ (fig-forth-auto680):00845 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00846 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00847 * This is only for Forth code stream.
+ (fig-forth-auto680):00848 * Also, see comments for LIT.
+1432 87 (fig-forth-auto680):00849 FCB $87
+1433 282B4C4F4F50 (fig-forth-auto680):00850 FCC '(+LOOP' ; '(+LOOP)'
+1439 A9 (fig-forth-auto680):00851 FCB $A9
+143A 1414 (fig-forth-auto680):00852 FDB XLOOP-9
+143C 143E (fig-forth-auto680):00853 XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
+143E ECC1 (fig-forth-auto680):00854 LDD ,U++ ; inc val
+1440 2AE0 (fig-forth-auto680):00855 BPL XLOOPA ; Steal plain loop code for forward count.
+1442 E362 (fig-forth-auto680):00856 ADDD NATWID,S ; Dodge the return address
+1444 ED62 (fig-forth-auto680):00857 STD NATWID,S
+1446 A364 (fig-forth-auto680):00858 SUBD 2*NATWID,S
+1448 2EC5 (fig-forth-auto680):00859 BGT ZBYES ; signed
+144A 20DE (fig-forth-auto680):00860 BRA XLOOPN ; This path is less time-sensitive.
+ (fig-forth-auto680):00861 *
+ (fig-forth-auto680):00862 * This should work, but I want to use tested code.
+ (fig-forth-auto680):00863 * PULU A,B ; Get the increment.
+ (fig-forth-auto680):00864 * XPLOP2 PULS X ; Pre-clear the return stack.
+ (fig-forth-auto680):00865 * PSHU A ; Save the direction in high bit.
+ (fig-forth-auto680):00866 * ADDD ,S ; Count.
+ (fig-forth-auto680):00867 * STD ,S ; Update.
+ (fig-forth-auto680):00868 * SUBD NATWID,S ; Check limit.
+ (fig-forth-auto680):00869 **
+ (fig-forth-auto680):00870 ** I think this should work:
+ (fig-forth-auto680):00871 * EORA ,U+ ; dir < 0 and (count - limit) >= 0
+ (fig-forth-auto680):00872 * BPL XPLONO ; or dir >= 0 and (count - limit) < 0
+ (fig-forth-auto680):00873 * LDD ,Y++
+ (fig-forth-auto680):00874 * LEAY D,Y ; IP is postinc
+ (fig-forth-auto680):00875 * JMP ,X
+ (fig-forth-auto680):00876 * XPLONO LEAS 2*NATWID,S
+ (fig-forth-auto680):00877 * JMP ,X ; synthetic return
+ (fig-forth-auto680):00878 *
+ (fig-forth-auto680):00879 * This definitely should work:
+ (fig-forth-auto680):00880 * TST ,U+ ; Get the sign
+ (fig-forth-auto680):00881 * BPL XPLOF ;
+ (fig-forth-auto680):00882 * CMPD NATWID,S
+ (fig-forth-auto680):00883 * BMI XPLONO
+ (fig-forth-auto680):00884 * XPLOYE LDD ,Y++
+ (fig-forth-auto680):00885 * LEAY D,Y ; IP is postinc
+ (fig-forth-auto680):00886 * JMP ,X
+ (fig-forth-auto680):00887 * XPLOF CMPD NATWID,S
+ (fig-forth-auto680):00888 * BMI XPLOYE
+ (fig-forth-auto680):00889 * XPLONO LEAS 2*NATWID,S
+ (fig-forth-auto680):00890 * JMP ,X ; synthetic return
+ (fig-forth-auto680):00891 *
+ (fig-forth-auto680):00892 * 6800 Probably could have used the exclusive-or method, too.:
+ (fig-forth-auto680):00893 * PULS A ; get increment
+ (fig-forth-auto680):00894 * PULS B ;
+ (fig-forth-auto680):00895 * XPLOP2 TSTA ;
+ (fig-forth-auto680):00896 * BPL XPLOF forward looping
+ (fig-forth-auto680):00897 * BSR XPLOPS
+ (fig-forth-auto680):00898 * ORCC #$01 ; SEC :
+ (fig-forth-auto680):00899 * SBCB 5,X
+ (fig-forth-auto680):00900 * SBCA 4,X
+ (fig-forth-auto680):00901 * BPL ZBYES
+ (fig-forth-auto680):00902 * BRA XPLONO fall through
+ (fig-forth-auto680):00903 *
+ (fig-forth-auto680):00904 * the subroutine :
+ (fig-forth-auto680):00905 * XPLOPS LDX RP
+ (fig-forth-auto680):00906 * ADDB 3,X add it to counter
+ (fig-forth-auto680):00907 * ADCA 2,X
+ (fig-forth-auto680):00908 * STB 3,X store new counter value
+ (fig-forth-auto680):00909 * STA 2,X
+ (fig-forth-auto680):00910 * RTS
+ (fig-forth-auto680):00911 *
+ (fig-forth-auto680):00912 * XPLOF BSR XPLOPS
+ (fig-forth-auto680):00913 * SUBB 5,X
+ (fig-forth-auto680):00914 * SBCA 4,X
+ (fig-forth-auto680):00915 * BMI ZBYES
+ (fig-forth-auto680):00916 *
+ (fig-forth-auto680):00917 * XPLONO LEAX 1,X ; done, don't branch back
+ (fig-forth-auto680):00918 * LEAX 1,X ;
+ (fig-forth-auto680):00919 * LEAX 1,X ;
+ (fig-forth-auto680):00920 * LEAX 1,X ;
+ (fig-forth-auto680):00921 * STX RP
+ (fig-forth-auto680):00922 * BRA ZBNO use ZBRAN to skip over unused delta
+ (fig-forth-auto680):00923 *
+ (fig-forth-auto680):00924 * ######>> screen 17 <<
+ (fig-forth-auto680):00925 * ======>> 8 <<
+ (fig-forth-auto680):00926 * ( limit index --- ) ( *** limit index )
+ (fig-forth-auto680):00927 * Move the loop parameters to the return stack. Synonym for D>R.
+144C 84 (fig-forth-auto680):00928 FCB $84
+144D 28444F (fig-forth-auto680):00929 FCC '(DO' ; '(DO)'
+1450 A9 (fig-forth-auto680):00930 FCB $A9
+1451 1432 (fig-forth-auto680):00931 FDB XPLOOP-10
+1453 1455 (fig-forth-auto680):00932 XDO FDB *+NATWID This is the RUNTIME DO, not the COMPILING DO
+1455 AEE4 (fig-forth-auto680):00933 LDX ,S ; Save the return address.
+1457 3706 (fig-forth-auto680):00934 PULU A,B
+1459 3406 (fig-forth-auto680):00935 PSHS A,B
+145B 3706 (fig-forth-auto680):00936 PULU A,B ; Maintain order.
+145D ED62 (fig-forth-auto680):00937 STD NATWID,S
+145F 6E84 (fig-forth-auto680):00938 JMP ,X ; synthetic return
+ (fig-forth-auto680):00939 *
+ (fig-forth-auto680):00940 * LDX RP
+ (fig-forth-auto680):00941 * LEAX -1,X ;
+ (fig-forth-auto680):00942 * LEAX -1,X ;
+ (fig-forth-auto680):00943 * LEAX -1,X ;
+ (fig-forth-auto680):00944 * LEAX -1,X ;
+ (fig-forth-auto680):00945 * STX RP
+ (fig-forth-auto680):00946 * PULS A ;
+ (fig-forth-auto680):00947 * PULS B ;
+ (fig-forth-auto680):00948 * STA 2,X
+ (fig-forth-auto680):00949 * STB 3,X
+ (fig-forth-auto680):00950 * PULS A ;
+ (fig-forth-auto680):00951 * PULS B ;
+ (fig-forth-auto680):00952 * STA 4,X
+ (fig-forth-auto680):00953 * STB 5,X
+ (fig-forth-auto680):00954 * JMP NEXT
+ (fig-forth-auto680):00955 *
+ (fig-forth-auto680):00956 * ======>> 9 <<
+ (fig-forth-auto680):00957 * ( --- index ) ( limit index *** limit index )
+ (fig-forth-auto680):00958 * Copy the loop index from the return stack. Synonym for R.
+1461 81 (fig-forth-auto680):00959 FCB $81 I
+1462 C9 (fig-forth-auto680):00960 FCB $C9
+1463 144C (fig-forth-auto680):00961 FDB XDO-7
+1465 1467 (fig-forth-auto680):00962 I FDB *+NATWID
+1467 EC62 (fig-forth-auto680):00963 LDD NATWID,S ; Dodge return address.
+1469 3606 (fig-forth-auto680):00964 PSHU A,B
+146B 39 (fig-forth-auto680):00965 RTS
+ (fig-forth-auto680):00966 * LDX RP
+ (fig-forth-auto680):00967 * LEAX 1,X ;
+ (fig-forth-auto680):00968 * LEAX 1,X ;
+ (fig-forth-auto680):00969 * JMP GETX
+ (fig-forth-auto680):00970 *
+ (fig-forth-auto680):00971 * ######>> screen 18 <<
+ (fig-forth-auto680):00972 * ======>> 10 <<
+ (fig-forth-auto680):00973 * ( c base --- false )
+ (fig-forth-auto680):00974 * ( c base --- n true )
+ (fig-forth-auto680):00975 * Translate C in base, yielding a translation valid flag. If the
+ (fig-forth-auto680):00976 * translation is not valid in the specified base, only the false
+ (fig-forth-auto680):00977 * flag is returned.
+146C 85 (fig-forth-auto680):00978 FCB $85
+146D 44494749 (fig-forth-auto680):00979 FCC 'DIGI' ; 'DIGIT'
+1471 D4 (fig-forth-auto680):00980 FCB $D4
+1472 1461 (fig-forth-auto680):00981 FDB I-4
+1474 1476 (fig-forth-auto680):00982 DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
+1476 EC42 (fig-forth-auto680):00983 LDD NATWID,U ; Check the whole thing.
+1478 830030 (fig-forth-auto680):00984 SUBD #$30 ; ascii zero
+147B 2B22 (fig-forth-auto680):00985 BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+147D 1083000A (fig-forth-auto680):00986 CMPD #$A
+1481 2B0F (fig-forth-auto680):00987 BMI DIGIT0 IF '9' OR LESS
+1483 10830011 (fig-forth-auto680):00988 CMPD #$11
+1487 2B16 (fig-forth-auto680):00989 BMI DIGIT2 if less than 'A'
+1489 1083002B (fig-forth-auto680):00990 CMPD #$2B
+148D 2A10 (fig-forth-auto680):00991 BPL DIGIT2 if greater than 'Z'
+148F 830007 (fig-forth-auto680):00992 SUBD #7 translate 'A' thru 'F'
+1492 10A3C4 (fig-forth-auto680):00993 DIGIT0 CMPD ,U ; Check the base.
+1495 2A08 (fig-forth-auto680):00994 BPL DIGIT2 if not less than the base
+1497 ED42 (fig-forth-auto680):00995 STD NATWID,U ; Store converted digit. (High byte known zero.)
+1499 CC0001 (fig-forth-auto680):00996 LDD #1 ; set valid flag
+149C EDC4 (fig-forth-auto680):00997 DIGIT1 STD ,U ; store the flag
+149E 39 (fig-forth-auto680):00998 RTS NEXT
+149F CC0000 (fig-forth-auto680):00999 DIGIT2 LDD #0 ; set not valid flag
+14A2 3342 (fig-forth-auto680):01000 LEAU NATWID,U ; pop base
+14A4 20F6 (fig-forth-auto680):01001 BRA DIGIT1
+ (fig-forth-auto680):01002 * TFR S,X ; TSX :
+ (fig-forth-auto680):01003 * LDA 3,X
+ (fig-forth-auto680):01004 * SUBA #$30 ascii zero
+ (fig-forth-auto680):01005 * BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+ (fig-forth-auto680):01006 * CMPA #$A
+ (fig-forth-auto680):01007 * BMI DIGIT0 IF '9' OR LESS
+ (fig-forth-auto680):01008 * CMPA #$11
+ (fig-forth-auto680):01009 * BMI DIGIT2 if less than 'A'
+ (fig-forth-auto680):01010 * CMPA #$2B
+ (fig-forth-auto680):01011 * BPL DIGIT2 if greater than 'Z'
+ (fig-forth-auto680):01012 * SUBA #7 translate 'A' thru 'F'
+ (fig-forth-auto680):01013 * DIGIT0 CMPA 1,X
+ (fig-forth-auto680):01014 * BPL DIGIT2 if not less than the base
+ (fig-forth-auto680):01015 * LDB #1 set flag
+ (fig-forth-auto680):01016 * STA 3,X store digit
+ (fig-forth-auto680):01017 * DIGIT1 STB 1,X store the flag
+ (fig-forth-auto680):01018 * JMP NEXT
+ (fig-forth-auto680):01019 * DIGIT2 CLRB ;
+ (fig-forth-auto680):01020 * LEAS 1,S ;
+ (fig-forth-auto680):01021 * LEAS 1,S ; pop bottom number
+ (fig-forth-auto680):01022 * TFR S,X ; TSX :
+ (fig-forth-auto680):01023 * STB 0,X make sure both bytes are 00
+ (fig-forth-auto680):01024 * BRA DIGIT1
+ (fig-forth-auto680):01025 *
+ (fig-forth-auto680):01026 * ######>> screen 19 <<
+ (fig-forth-auto680):01027 *
+ (fig-forth-auto680):01028 * The word definition format in the dictionary:
+ (fig-forth-auto680):01029 *
+ (fig-forth-auto680):01030 * (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
+ (fig-forth-auto680):01031 *
+ (fig-forth-auto680):01032 * NFA (name field address):
+ (fig-forth-auto680):01033 * char-count + $80 Length of symbol name, flagged with high bit set.
+ (fig-forth-auto680):01034 * char 1 Characters of symbol name.
+ (fig-forth-auto680):01035 * char 2
+ (fig-forth-auto680):01036 * ...
+ (fig-forth-auto680):01037 * char n + $80 symbol termination flag (char set < 128 code points)
+ (fig-forth-auto680):01038 * LFA (link field address):
+ (fig-forth-auto680):01039 * link high byte \___pointer to previous word in list
+ (fig-forth-auto680):01040 * link low byte / -- Combined allocation/dictionary list. --
+ (fig-forth-auto680):01041 * CFA (code field address):
+ (fig-forth-auto680):01042 * CFA high byte \___pointer to native CPU machine code
+ (fig-forth-auto680):01043 * CFA low byte / -- Consider this the characteristic code. --
+ (fig-forth-auto680):01044 * PFA (parameter field address):
+ (fig-forth-auto680):01045 * parameter fields -- Machine code for low-level native machine CPU code,
+ (fig-forth-auto680):01046 * " instruction list for high-level Forth code,
+ (fig-forth-auto680):01047 * " constant data for constants, pointers to per task variables,
+ (fig-forth-auto680):01048 * " space for variables, for global variables, etc.
+ (fig-forth-auto680):01049 *
+ (fig-forth-auto680):01050 * In the case of native CPU machine code, the address at CFA will be PFA.
+ (fig-forth-auto680):01051
+ (fig-forth-auto680):01052 * Definition attributes:
+ 0040 (fig-forth-auto680):01053 FIMMED EQU $40 ; Immediate word flag.
+ 0020 (fig-forth-auto680):01054 FSMUDG EQU $20 ; Smudged => definition not ready.
+ 003F (fig-forth-auto680):01055 CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte.
+ (fig-forth-auto680):01056 * Note that the SMUDGE bit is not masked out.
+ (fig-forth-auto680):01057 *
+ (fig-forth-auto680):01058 * But we really want more (Thinking for a new model, need one more byte):
+ (fig-forth-auto680):01059 * FCOMPI EQU $10 ; Compile-time-only.
+ (fig-forth-auto680):01060 * FASSEM EQU $08 ; Assembly-language code only.
+ (fig-forth-auto680):01061 * F4THLV EQU $04 ; Must not be called from assembly language code.
+ (fig-forth-auto680):01062 * These would require some significant adjustments to the model.
+ (fig-forth-auto680):01063 * We also want to put the low-level VM stuff in its own vocabulary.
+ (fig-forth-auto680):01064 *
+ (fig-forth-auto680):01065 * ======>> 11 <<
+ (fig-forth-auto680):01066 * (FIND) ( name vocptr --- locptr length true )
+ (fig-forth-auto680):01067 * ( name vocptr --- false )
+ (fig-forth-auto680):01068 * Search vocabulary for a symbol called name.
+ (fig-forth-auto680):01069 * name is a pointer to a high-bit bracket string with length head.
+ (fig-forth-auto680):01070 * vocptr is a pointer to the NFA of the tail-end (LATEST) definition
+ (fig-forth-auto680):01071 * in the vocabulary to be searched.
+ (fig-forth-auto680):01072 * Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
+14A6 86 (fig-forth-auto680):01073 FCB $86
+14A7 2846494E44 (fig-forth-auto680):01074 FCC '(FIND' ; '(FIND)'
+14AC A9 (fig-forth-auto680):01075 FCB $A9
+14AD 146C (fig-forth-auto680):01076 FDB DIGIT-8
+14AF 14B1 (fig-forth-auto680):01077 PFIND FDB *+NATWID
+14B1 3420 (fig-forth-auto680):01078 PSHS Y ; Have to track two pointers.
+ (fig-forth-auto680):01079 * Use the stack and registers instead of temp area N.
+ 0002 (fig-forth-auto680):01080 PA0 EQU NATWID ; pointer to the length byte of name being searched against
+ 0000 (fig-forth-auto680):01081 PD EQU 0 ; pointer to NFA of dict word being checked
+ (fig-forth-auto680):01082 *
+ (fig-forth-auto680):01083 * INC <TRACEM
+ (fig-forth-auto680):01084 * LBSR DBGREG
+14B3 AEC4 (fig-forth-auto680):01085 LDX PD,U ; Start in on the vocabulary (NFA).
+14B5 10AE42 (fig-forth-auto680):01086 PFNDLP LDY PA0,U ; Point to the name to check against.
+14B8 E680 (fig-forth-auto680):01087 LDB ,X+ ; get dict name length byte
+14BA 1F98 (fig-forth-auto680):01088 TFR B,A ; Save it in case it matches.
+14BC C43F (fig-forth-auto680):01089 ANDB #CTMASK
+ (fig-forth-auto680):01090 * LBSR DBGREG
+14BE E1A0 (fig-forth-auto680):01091 CMPB ,Y+ ; Compare lengths
+ (fig-forth-auto680):01092 * LBSR DBGREG
+14C0 261C (fig-forth-auto680):01093 BNE PFNDUN
+14C2 E680 (fig-forth-auto680):01094 PFNDBR LDB ,X+
+14C4 5D (fig-forth-auto680):01095 TSTB ; ; Is high bit of character in dictionary entry set?
+ (fig-forth-auto680):01096 * LBSR DBGREG
+14C5 2A13 (fig-forth-auto680):01097 BPL PFNDCH
+ (fig-forth-auto680):01098 * LBSR DBGREG
+14C7 C47F (fig-forth-auto680):01099 ANDB #$7F ; Clear high bit from dictionary.
+14C9 E1A0 (fig-forth-auto680):01100 CMPB ,Y+ ; Compare "last" characters.
+ (fig-forth-auto680):01101 * LBSR DBGREG
+14CB 2717 (fig-forth-auto680):01102 BEQ FOUND ; Matches even if dictionary actual length is shorter.
+14CD AE81 (fig-forth-auto680):01103 PFNDLN LDX ,X++ ; Get previous link in vocabulary.
+ (fig-forth-auto680):01104 * LBSR DBGREG
+14CF 26E4 (fig-forth-auto680):01105 BNE PFNDLP ; Continue if link not=0
+ (fig-forth-auto680):01106 *
+ (fig-forth-auto680):01107 * not found :
+14D1 3342 (fig-forth-auto680):01108 LEAU NATWID,U ; Return only false flag.
+14D3 CC0000 (fig-forth-auto680):01109 LDD #0
+14D6 EDC4 (fig-forth-auto680):01110 STD ,U
+ (fig-forth-auto680):01111 * LBSR DBGREG
+ (fig-forth-auto680):01112 * DEC <TRACEM
+14D8 35A0 (fig-forth-auto680):01113 PULS Y,PC
+ (fig-forth-auto680):01114 *
+14DA E1A0 (fig-forth-auto680):01115 PFNDCH CMPB ,Y+ ; Compare characters.
+ (fig-forth-auto680):01116 * LBSR DBGREG
+14DC 27E4 (fig-forth-auto680):01117 BEQ PFNDBR
+14DE (fig-forth-auto680):01118 PFNDUN
+14DE E680 (fig-forth-auto680):01119 PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
+ (fig-forth-auto680):01120 * LBSR DBGREG
+14E0 2AFC (fig-forth-auto680):01121 BPL PFNDSC
+ (fig-forth-auto680):01122 * LBSR DBGREG
+14E2 20E9 (fig-forth-auto680):01123 BRA PFNDLN
+ (fig-forth-auto680):01124 *
+ (fig-forth-auto680):01125 * found :
+ (fig-forth-auto680):01126 *
+14E4 3004 (fig-forth-auto680):01127 FOUND LEAX 2*NATWID,X
+ (fig-forth-auto680):01128 * LBSR DBGREG
+14E6 AF42 (fig-forth-auto680):01129 STX NATWID,U
+14E8 1F89 (fig-forth-auto680):01130 TFR A,B
+14EA 4F (fig-forth-auto680):01131 CLRA
+14EB EDC4 (fig-forth-auto680):01132 STD ,U
+ (fig-forth-auto680):01133 * LBSR DBGREG
+14ED C601 (fig-forth-auto680):01134 LDB #1
+14EF 3606 (fig-forth-auto680):01135 PSHU A,B
+ (fig-forth-auto680):01136 * LBSR DBGREG
+ (fig-forth-auto680):01137 * DEC <TRACEM
+14F1 35A0 (fig-forth-auto680):01138 PULS Y,PC
+ (fig-forth-auto680):01139 *
+ (fig-forth-auto680):01140 * 6800 model:
+ (fig-forth-auto680):01141 * NOP ; Probably leftovers from a debugging session.
+ (fig-forth-auto680):01142 * NOP
+ (fig-forth-auto680):01143 * PD EQU N ptr to dict word being checked
+ (fig-forth-auto680):01144 * PA0 EQU N+2
+ (fig-forth-auto680):01145 * PA EQU N+4
+ (fig-forth-auto680):01146 * PC EQU N+6
+ (fig-forth-auto680):01147 * LDX #PD
+ (fig-forth-auto680):01148 * LDB #4
+ (fig-forth-auto680):01149 * PFIND0 PULS A ; loop to get arguments
+ (fig-forth-auto680):01150 * STA 0,X
+ (fig-forth-auto680):01151 * LEAX 1,X ;
+ (fig-forth-auto680):01152 * DECB ;
+ (fig-forth-auto680):01153 * BNE PFIND0
+ (fig-forth-auto680):01154 *
+ (fig-forth-auto680):01155 * LDX PD
+ (fig-forth-auto680):01156 * PFNDLP LDB 0,X get count dict count
+ (fig-forth-auto680):01157 * STB PC
+ (fig-forth-auto680):01158 * ANDB #$3F
+ (fig-forth-auto680):01159 * LEAX 1,X ;
+ (fig-forth-auto680):01160 * STX PD update PD
+ (fig-forth-auto680):01161 * LDX PA0
+ (fig-forth-auto680):01162 * LDA 0,X get count from arg
+ (fig-forth-auto680):01163 * LEAX 1,X ;
+ (fig-forth-auto680):01164 * STX PA intialize PA
+ (fig-forth-auto680):01165 * PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01166 * CMPA ,S+ ; compare lengths
+ (fig-forth-auto680):01167 * BNE PFNDUN
+ (fig-forth-auto680):01168 * PFNDBR LDX PA
+ (fig-forth-auto680):01169 * LDA 0,X
+ (fig-forth-auto680):01170 * LEAX 1,X ;
+ (fig-forth-auto680):01171 * STX PA
+ (fig-forth-auto680):01172 * LDX PD
+ (fig-forth-auto680):01173 * LDB 0,X
+ (fig-forth-auto680):01174 * LEAX 1,X ;
+ (fig-forth-auto680):01175 * STX PD
+ (fig-forth-auto680):01176 * TSTB ; is dict entry neg. ?
+ (fig-forth-auto680):01177 * BPL PFNDCH
+ (fig-forth-auto680):01178 * ANDB #$7F clear sign
+ (fig-forth-auto680):01179 * PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01180 * CMPA ,S+ ;
+ (fig-forth-auto680):01181 * BEQ FOUND
+ (fig-forth-auto680):01182 * PFNDLN LDX 0,X get new link
+ (fig-forth-auto680):01183 * BNE PFNDLP continue if link not=0
+ (fig-forth-auto680):01184 *
+ (fig-forth-auto680):01185 * not found :
+ (fig-forth-auto680):01186 *
+ (fig-forth-auto680):01187 * CLRA ;
+ (fig-forth-auto680):01188 * CLRB ;
+ (fig-forth-auto680):01189 * JMP PUSHBA
+ (fig-forth-auto680):01190 * PFNDCH PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01191 * CMPA ,S+ ;
+ (fig-forth-auto680):01192 * BEQ PFNDBR
+ (fig-forth-auto680):01193 * PFNDUN LDX PD
+ (fig-forth-auto680):01194 * PFNDSC LDB 0,X scan forward to end of this name
+ (fig-forth-auto680):01195 * LEAX 1,X ;
+ (fig-forth-auto680):01196 * BPL PFNDSC
+ (fig-forth-auto680):01197 * BRA PFNDLN
+ (fig-forth-auto680):01198 *
+ (fig-forth-auto680):01199 * found :
+ (fig-forth-auto680):01200 *
+ (fig-forth-auto680):01201 * FOUND LDA PD compute CFA
+ (fig-forth-auto680):01202 * LDB PD+1
+ (fig-forth-auto680):01203 * ADDB #4
+ (fig-forth-auto680):01204 * ADCA #0
+ (fig-forth-auto680):01205 * PSHS B ;
+ (fig-forth-auto680):01206 * PSHS A ;
+ (fig-forth-auto680):01207 * LDA PC
+ (fig-forth-auto680):01208 * PSHS A ;
+ (fig-forth-auto680):01209 * CLRA ;
+ (fig-forth-auto680):01210 * PSHS A ;
+ (fig-forth-auto680):01211 * LDB #1
+ (fig-forth-auto680):01212 * JMP PUSHBA
+ (fig-forth-auto680):01213 *
+ (fig-forth-auto680):01214 * PSHS A ; Left over from a stray copy-paste, I guess.
+ (fig-forth-auto680):01215 * CLRA ;
+ (fig-forth-auto680):01216 * PSHS A ;
+ (fig-forth-auto680):01217 * LDB #1
+ (fig-forth-auto680):01218 * JMP PUSHBA
+ (fig-forth-auto680):01219 *
+ (fig-forth-auto680):01220 * ######>> screen 20 <<
+ (fig-forth-auto680):01221 * ======>> 12 <<
+ (fig-forth-auto680):01222 * ( buffer ch --- buffer symboloffset delimiteroffset scancount )
+ (fig-forth-auto680):01223 * ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
+ (fig-forth-auto680):01224 * ( buffer ch --- buffer nuloffset onepast scancount )
+ (fig-forth-auto680):01225 * Scan buffer for a symbol delimited by ch or ASCII NUL,
+ (fig-forth-auto680):01226 * return the length of the buffer region scanned,
+ (fig-forth-auto680):01227 * the offset to the trailing delimiter,
+ (fig-forth-auto680):01228 * and the offset of the first character of the symbol.
+ (fig-forth-auto680):01229 * Leave the buffer on the stack.
+ (fig-forth-auto680):01230 * Scancount is also offset to first character not yet looked at.
+ (fig-forth-auto680):01231 * If no symbol in buffer, scancount and symboloffset point to NUL
+ (fig-forth-auto680):01232 * and delimiteroffset points one beyond for some reason.
+ (fig-forth-auto680):01233 * On trailing NUL, delimiteroffset == scancount.
+ (fig-forth-auto680):01234 * (Buffer is the address of the buffer array to scan.)
+ (fig-forth-auto680):01235 * (This is a bit too tricky, really.)
+14F3 87 (fig-forth-auto680):01236 FCB $87
+14F4 454E434C4F53 (fig-forth-auto680):01237 FCC 'ENCLOS' ; 'ENCLOSE'
+14FA C5 (fig-forth-auto680):01238 FCB $C5
+14FB 14A6 (fig-forth-auto680):01239 FDB PFIND-9
+14FD 14FF (fig-forth-auto680):01240 ENCLOS FDB *+NATWID
+14FF A641 (fig-forth-auto680):01241 LDA 1,U ; Delimiter character to match against in A.
+1501 AE42 (fig-forth-auto680):01242 LDX NATWID,U ; Buffer to scan in.
+1503 5F (fig-forth-auto680):01243 CLRB ; Initialize offset. (Buffer < 256 wide!)
+ (fig-forth-auto680):01244 * Scan to a non-delimiter or a NUL
+1504 6D85 (fig-forth-auto680):01245 ENCDEL TST B,X ; NUL ?
+1506 271F (fig-forth-auto680):01246 BEQ ENCNUL
+1508 A185 (fig-forth-auto680):01247 CMPA B,X ; Delimiter?
+150A 2603 (fig-forth-auto680):01248 BNE ENC1ST
+150C 5C (fig-forth-auto680):01249 INCB ; count character
+150D 20F5 (fig-forth-auto680):01250 BRA ENCDEL
+ (fig-forth-auto680):01251 * Found first character. Save the offset.
+150F E741 (fig-forth-auto680):01252 ENC1ST STB 1,U ; Found first non-delimiter character --
+1511 6FC4 (fig-forth-auto680):01253 CLR ,U ; store the count, zero high byte.
+ (fig-forth-auto680):01254 * Scan to a delimiter or a NUL
+1513 6D85 (fig-forth-auto680):01255 ENCSYM TST B,X ; NUL ?
+1515 271E (fig-forth-auto680):01256 BEQ ENC0TR
+1517 A185 (fig-forth-auto680):01257 CMPA B,X ; delimiter?
+1519 2703 (fig-forth-auto680):01258 BEQ ENCEND
+151B 5C (fig-forth-auto680):01259 INCB
+151C 20F5 (fig-forth-auto680):01260 BRA ENCSYM
+ (fig-forth-auto680):01261 * Found end of symbol. Push offset to delimiter found.
+151E 4F (fig-forth-auto680):01262 ENCEND CLRA ; high byte -- buffer < 255 wide!
+151F 3606 (fig-forth-auto680):01263 PSHU A,B ; Offset to seen delimiter.
+ (fig-forth-auto680):01264 * Advance and push address of next character to check.
+1521 C30001 (fig-forth-auto680):01265 ADDD #1 ; In case offset was 255.
+1524 3606 (fig-forth-auto680):01266 PSHU A,B
+1526 39 (fig-forth-auto680):01267 RTS
+ (fig-forth-auto680):01268 * Found NUL before non-delimiter, therefore there is no word
+1527 4F (fig-forth-auto680):01269 ENCNUL CLRA ; high byte -- buffer < 255 wide!
+1528 EDC4 (fig-forth-auto680):01270 STD ,U ; offset to NUL.
+152A C30001 (fig-forth-auto680):01271 ADDD #1 ; Point after NUL to allow (FIND) to match it.
+152D 3606 (fig-forth-auto680):01272 PSHU A,B ;
+152F 830001 (fig-forth-auto680):01273 SUBD #1 ; Next is not passed NUL.
+1532 3606 (fig-forth-auto680):01274 PSHU A,B ; Stealing code will save only one byte.
+1534 39 (fig-forth-auto680):01275 RTS
+ (fig-forth-auto680):01276 * Found NUL following the word instead of delimiter.
+1535 (fig-forth-auto680):01277 ENC0TR
+ (fig-forth-auto680):01278 * INC <TRACEM
+ (fig-forth-auto680):01279 * LBSR DBGREG
+1535 4F (fig-forth-auto680):01280 CLRA
+1536 3606 (fig-forth-auto680):01281 PSHU A,B ; Save offset to first after symbol (NUL)
+ (fig-forth-auto680):01282 * LBSR DBGREG
+1538 3606 (fig-forth-auto680):01283 PSHU A,B ; and count scanned.
+ (fig-forth-auto680):01284 * LBSR DBGREG
+ (fig-forth-auto680):01285 * DEC <TRACEM
+153A 39 (fig-forth-auto680):01286 RTS
+ (fig-forth-auto680):01287 * NOTE :
+ (fig-forth-auto680):01288 * FC means offset (bytes) to First Character of next word
+ (fig-forth-auto680):01289 * EW " " to End of Word
+ (fig-forth-auto680):01290 * NC " " to Next Character to start next enclose at
+ (fig-forth-auto680):01291 * ENCLOS FDB *+NATWID
+ (fig-forth-auto680):01292 * LEAS 1,S ;
+ (fig-forth-auto680):01293 * PULS B ; now, get the low byte, for an 8-bit delimiter
+ (fig-forth-auto680):01294 * TFR S,X ; TSX :
+ (fig-forth-auto680):01295 * LDX 0,X
+ (fig-forth-auto680):01296 * CLR N
+ (fig-forth-auto680):01297 * * wait for a non-delimiter or a NUL
+ (fig-forth-auto680):01298 * ENCDEL LDA 0,X
+ (fig-forth-auto680):01299 * BEQ ENCNUL
+ (fig-forth-auto680):01300 * PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01301 * CMPA ,S+ ; CHECK FOR DELIM
+ (fig-forth-auto680):01302 * BNE ENC1ST
+ (fig-forth-auto680):01303 * LEAX 1,X ;
+ (fig-forth-auto680):01304 * INC N
+ (fig-forth-auto680):01305 * BRA ENCDEL
+ (fig-forth-auto680):01306 * * found first character. Push FC
+ (fig-forth-auto680):01307 * ENC1ST LDA N found first char.
+ (fig-forth-auto680):01308 * PSHS A ;
+ (fig-forth-auto680):01309 * CLRA ;
+ (fig-forth-auto680):01310 * PSHS A ;
+ (fig-forth-auto680):01311 * wait for a delimiter or a NUL
+ (fig-forth-auto680):01312 * ENCSYM LDA 0,X
+ (fig-forth-auto680):01313 * BEQ ENC0TR
+ (fig-forth-auto680):01314 * PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01315 * CMPA ,S+ ; ckech for delim.
+ (fig-forth-auto680):01316 * BEQ ENCEND
+ (fig-forth-auto680):01317 * LEAX 1,X ;
+ (fig-forth-auto680):01318 * INC N
+ (fig-forth-auto680):01319 * BRA ENCSYM
+ (fig-forth-auto680):01320 * * found EW. Push it
+ (fig-forth-auto680):01321 * ENCEND LDB N
+ (fig-forth-auto680):01322 * CLRA ;
+ (fig-forth-auto680):01323 * PSHS B ;
+ (fig-forth-auto680):01324 * PSHS A ;
+ (fig-forth-auto680):01325 * * advance and push NC
+ (fig-forth-auto680):01326 * INCB ;
+ (fig-forth-auto680):01327 * JMP PUSHBA
+ (fig-forth-auto680):01328 * found NUL before non-delimiter, therefore there is no word
+ (fig-forth-auto680):01329 * ENCNUL LDB N found NUL
+ (fig-forth-auto680):01330 * PSHS B ;
+ (fig-forth-auto680):01331 * PSHS A ;
+ (fig-forth-auto680):01332 * INCB ;
+ (fig-forth-auto680):01333 * BRA ENC0TR+2 ; ********** POTENTIAL BUG HERE *******
+ (fig-forth-auto680):01334 * ******** Should use labels in case opcodes change! ********
+ (fig-forth-auto680):01335 * found NUL following the word instead of SPACE
+ (fig-forth-auto680):01336 * ENC0TR LDB N
+ (fig-forth-auto680):01337 * PSHS B ; save EW
+ (fig-forth-auto680):01338 * PSHS A ;
+ (fig-forth-auto680):01339 * ENCL8 LDB N save NC
+ (fig-forth-auto680):01340 * JMP PUSHBA
+ (fig-forth-auto680):01341
+ (fig-forth-auto680):01342 PAGE
+ (fig-forth-auto680):01343 *
+ (fig-forth-auto680):01344 * ######>> screen 21 <<
+ (fig-forth-auto680):01345 * The next 4 words call system dependant I/O routines
+ (fig-forth-auto680):01346 * which are listed after word "-->" ( lable: "arrow" )
+ (fig-forth-auto680):01347 * in the dictionary.
+ (fig-forth-auto680):01348 *
+ (fig-forth-auto680):01349 * ======>> 13 <<
+ (fig-forth-auto680):01350 * ( c --- )
+ (fig-forth-auto680):01351 * Write c to the output device (screen or printer).
+ (fig-forth-auto680):01352 * ROM Uses the ECB device number at address $6F,
+ (fig-forth-auto680):01353 * -2 is printer, 0 is screen.
+153B 84 (fig-forth-auto680):01354 FCB $84
+153C 454D49 (fig-forth-auto680):01355 FCC 'EMI' ; 'EMIT'
+153F D4 (fig-forth-auto680):01356 FCB $D4
+1540 14F3 (fig-forth-auto680):01357 FDB ENCLOS-10
+1542 1544 (fig-forth-auto680):01358 EMIT FDB *+NATWID
+1544 3706 (fig-forth-auto680):01359 PULU D
+1546 171067 (fig-forth-auto680):01360 LBSR PEMIT ; PEMIT expects the character in D.
+1549 0C33 (fig-forth-auto680):01361 INC <XOUT+1
+154B 2602 (fig-forth-auto680):01362 BNE EMITDN
+154D 0C32 (fig-forth-auto680):01363 INC <XOUT
+154F 39 (fig-forth-auto680):01364 EMITDN RTS
+ (fig-forth-auto680):01365 * PULS A ;
+ (fig-forth-auto680):01366 * PULS A ;
+ (fig-forth-auto680):01367 * JSR PEMIT
+ (fig-forth-auto680):01368 * LDX UP
+ (fig-forth-auto680):01369 * INC XOUT+1-UORIG,X
+ (fig-forth-auto680):01370 * BNE *+4 ;
+ (fig-forth-auto680):01371 * ****WARNING**** HARD OFFSET: *+4 ****
+ (fig-forth-auto680):01372 * INC XOUT-UORIG,X
+ (fig-forth-auto680):01373 * JMP NEXT
+ (fig-forth-auto680):01374 *
+ (fig-forth-auto680):01375 * ======>> 14 <<
+ (fig-forth-auto680):01376 * ( --- c )
+ (fig-forth-auto680):01377 * ( --- BREAK )
+ (fig-forth-auto680):01378 * Wait for a key from the keyboard.
+ (fig-forth-auto680):01379 * If the key is BREAK, set the high byte (result $FF03).
+1550 83 (fig-forth-auto680):01380 FCB $83
+1551 4B45 (fig-forth-auto680):01381 FCC 'KE' ; 'KEY'
+1553 D9 (fig-forth-auto680):01382 FCB $D9
+1554 153B (fig-forth-auto680):01383 FDB EMIT-7
+1556 1558 (fig-forth-auto680):01384 KEY FDB *+NATWID
+1558 171062 (fig-forth-auto680):01385 LBSR PKEY ; PKEY leaves the key/break code in D.
+155B 3606 (fig-forth-auto680):01386 PSHU D
+155D 39 (fig-forth-auto680):01387 RTS
+ (fig-forth-auto680):01388 * JSR PKEY
+ (fig-forth-auto680):01389 * PSHS A ;
+ (fig-forth-auto680):01390 * CLRA ;
+ (fig-forth-auto680):01391 * PSHS A ;
+ (fig-forth-auto680):01392 * JMP NEXT
+ (fig-forth-auto680):01393 *
+ (fig-forth-auto680):01394 * ======>> 15 <<
+ (fig-forth-auto680):01395 * ( --- f )
+ (fig-forth-auto680):01396 * Scan keyboard, but do not wait.
+ (fig-forth-auto680):01397 * Return 0 if no key,
+ (fig-forth-auto680):01398 * BREAK ($ff03) if BREAK is pressed,
+ (fig-forth-auto680):01399 * or key currently pressed.
+155E 89 (fig-forth-auto680):01400 FCB $89
+155F 3F5445524D494E41 (fig-forth-auto680):01401 FCC '?TERMINA' ; '?TERMINAL'
+1567 CC (fig-forth-auto680):01402 FCB $CC
+1568 1550 (fig-forth-auto680):01403 FDB KEY-6
+156A 156C (fig-forth-auto680):01404 QTERM FDB *+NATWID
+156C 171073 (fig-forth-auto680):01405 LBSR PQTER ; PQTER leaves the flag/key in D.
+156F 3606 (fig-forth-auto680):01406 PSHU D
+1571 39 (fig-forth-auto680):01407 RTS
+ (fig-forth-auto680):01408 * JSR PQTER
+ (fig-forth-auto680):01409 * CLRB ;
+ (fig-forth-auto680):01410 * JMP PUSHBA stack the flag
+ (fig-forth-auto680):01411 *
+ (fig-forth-auto680):01412 * ======>> 16 <<
+ (fig-forth-auto680):01413 * ( --- )
+ (fig-forth-auto680):01414 * EMIT a Carriage Return (ASCII CR).
+1572 82 (fig-forth-auto680):01415 FCB $82
+1573 43 (fig-forth-auto680):01416 FCC 'C' ; 'CR'
+1574 D2 (fig-forth-auto680):01417 FCB $D2
+1575 155E (fig-forth-auto680):01418 FDB QTERM-12
+1577 1579 (fig-forth-auto680):01419 CR FDB *+NATWID
+1579 161071 (fig-forth-auto680):01420 LBRA PCR ; Nothing really to do here.
+ (fig-forth-auto680):01421 * JSR PCR
+ (fig-forth-auto680):01422 * JMP NEXT
+ (fig-forth-auto680):01423 *
+ (fig-forth-auto680):01424 * ######>> screen 22 <<
+ (fig-forth-auto680):01425 * ======>> 17 <<
+ (fig-forth-auto680):01426 * ( source target count --- )
+ (fig-forth-auto680):01427 * Copy/move count bytes from source to target.
+ (fig-forth-auto680):01428 * Moves ascending addresses,
+ (fig-forth-auto680):01429 * so that overlapping only works if the source is above the destination.
+157C 85 (fig-forth-auto680):01430 FCB $85
+157D 434D4F56 (fig-forth-auto680):01431 FCC 'CMOV' ; 'CMOVE' : source, destination, count
+1581 C5 (fig-forth-auto680):01432 FCB $C5
+1582 1572 (fig-forth-auto680):01433 FDB CR-5
+1584 1586 (fig-forth-auto680):01434 CMOVE FDB *+NATWID
+1586 3420 (fig-forth-auto680):01435 PSHS Y ;
+ (fig-forth-auto680):01436 * INC <TRACEM
+ (fig-forth-auto680):01437 * LBSR DBGREG
+1588 AE42 (fig-forth-auto680):01438 LDX 1*NATWID,U
+158A 10AE44 (fig-forth-auto680):01439 LDY 2*NATWID,U
+158D 2004 (fig-forth-auto680):01440 BRA CMOVLE ;
+158F (fig-forth-auto680):01441 CMOVLP
+ (fig-forth-auto680):01442 * LBSR DBGREG
+158F A6A0 (fig-forth-auto680):01443 LDA ,Y+
+1591 A780 (fig-forth-auto680):01444 STA ,X+
+ (fig-forth-auto680):01445 * LBSR DBGREG
+1593 (fig-forth-auto680):01446 CMOVLE
+1593 ECC4 (fig-forth-auto680):01447 LDD ,U
+1595 830001 (fig-forth-auto680):01448 SUBD #1
+1598 EDC4 (fig-forth-auto680):01449 STD ,U
+159A 24F3 (fig-forth-auto680):01450 BCC CMOVLP
+159C 3346 (fig-forth-auto680):01451 LEAU 3*NATWID,U
+ (fig-forth-auto680):01452 * DEC <TRACEM
+159E 35A0 (fig-forth-auto680):01453 PULS Y,PC
+ (fig-forth-auto680):01454 * One way: ; takes ( 37+17*count+9*(count/256) cycles )
+ (fig-forth-auto680):01455 * PSHS Y ; #2~7 ; Gotta have our pointers.
+ (fig-forth-auto680):01456 * INC <TRACEM
+ (fig-forth-auto680):01457 * LBSR DBGREG
+ (fig-forth-auto680):01458 * PULU D,X,Y ; #2~11
+ (fig-forth-auto680):01459 * PSHS A ; #2~6 ; Gotta have our pointers.
+ (fig-forth-auto680):01460 * BRA CMOVLE ; #2~3
+ (fig-forth-auto680):01461 * CMOVLP
+ (fig-forth-auto680):01462 * LBSR DBGREG
+ (fig-forth-auto680):01463 * LDA ,Y+ ; #2~6
+ (fig-forth-auto680):01464 * STA ,X+ ; #2~6
+ (fig-forth-auto680):01465 * LBSR DBGREG
+ (fig-forth-auto680):01466 * CMOVLE
+ (fig-forth-auto680):01467 * SUBB #1 ; #2~2
+ (fig-forth-auto680):01468 * BCC CMOVLP ; #2~3
+ (fig-forth-auto680):01469 * DEC ,S ; #2=6
+ (fig-forth-auto680):01470 * BPL CMOVLP ; #2~3
+ (fig-forth-auto680):01471 * DEC <TRACEM
+ (fig-forth-auto680):01472 * PULS A,Y,PC ; #2~10
+ (fig-forth-auto680):01473 * Another way ; takes ( 42+17*count+9*(count/256) cycles )
+ (fig-forth-auto680):01474 * LDD #0 ; #3~3
+ (fig-forth-auto680):01475 * SUBD ,U++ ; #2~9 ; invert the count
+ (fig-forth-auto680):01476 * PSHS A,Y ; #2~8
+ (fig-forth-auto680):01477 * PULU X,Y ; #2~9
+ (fig-forth-auto680):01478 * BEQ CMOVEX ; #2~3
+ (fig-forth-auto680):01479 * CMOVEL
+ (fig-forth-auto680):01480 * LDA ,Y+ ; #2~6
+ (fig-forth-auto680):01481 * STA ,X+ ; #2~6
+ (fig-forth-auto680):01482 * INCB ; #1~2
+ (fig-forth-auto680):01483 * BNE CMOVEL ; #2~3
+ (fig-forth-auto680):01484 * INC ,S ; #2~6
+ (fig-forth-auto680):01485 * BNE CMOVEL ; #2~3
+ (fig-forth-auto680):01486 * CMOVEX
+ (fig-forth-auto680):01487 * PULS A,Y,PC ; #2~10
+ (fig-forth-auto680):01488 * Yet another way ; takes ( 37+29*count cycles )
+ (fig-forth-auto680):01489 * PSHS Y ; #2~7
+ (fig-forth-auto680):01490 * LDX NATWID,U ; #2~6
+ (fig-forth-auto680):01491 * LDY NATWID,U ; #3~7
+ (fig-forth-auto680):01492 * BRA CMOVLE ; #2~3
+ (fig-forth-auto680):01493 * CMOVLP
+ (fig-forth-auto680):01494 * LDA ,Y+ ; #2~6
+ (fig-forth-auto680):01495 * STA ,X+ ; #2~6
+ (fig-forth-auto680):01496 * CMOVLE
+ (fig-forth-auto680):01497 * LDD ,U ; #2~5
+ (fig-forth-auto680):01498 * SUBD #1 ; #3~4
+ (fig-forth-auto680):01499 * STD ,U ; #2~5
+ (fig-forth-auto680):01500 * BPL CMOVLP ; #2~3
+ (fig-forth-auto680):01501 * LEAU 3*NATWID,U ; #2~5
+ (fig-forth-auto680):01502 * PULS Y,PC ; #2~9
+ (fig-forth-auto680):01503 * Yet another way ; takes ( 44+24*odd+33*count/2 cycles )
+ (fig-forth-auto680):01504 * PSHS Y ; #2~7
+ (fig-forth-auto680):01505 * LDX NATWID,U ; #2~6
+ (fig-forth-auto680):01506 * LDY 2*NATWID,U ; #3~7
+ (fig-forth-auto680):01507 * LDD ,U ; #2~5
+ (fig-forth-auto680):01508 * BITB #1 ; #2~2
+ (fig-forth-auto680):01509 * BEQ CMOVLE ; #2~3
+ (fig-forth-auto680):01510 * SUBD #1 ; #3~4
+ (fig-forth-auto680):01511 * STD ,U ; #2~5
+ (fig-forth-auto680):01512 * LDA ,Y+ ; #2~6
+ (fig-forth-auto680):01513 * STA ,X+ ; #2~6
+ (fig-forth-auto680):01514 * BRA CMOVLE ; #2~3
+ (fig-forth-auto680):01515 * CMOVLP
+ (fig-forth-auto680):01516 * LDD ,Y++ ; #2~8
+ (fig-forth-auto680):01517 * STD ,X++ ; #2~8
+ (fig-forth-auto680):01518 * CMOVLI
+ (fig-forth-auto680):01519 * LDD ,U ; #2~5
+ (fig-forth-auto680):01520 * CMOVLE
+ (fig-forth-auto680):01521 * SUBD #2 ; #3~4
+ (fig-forth-auto680):01522 * STD ,U ; #2~5
+ (fig-forth-auto680):01523 * BPL CMOVLP ; #2~3
+ (fig-forth-auto680):01524 * LEAU 3*NATWID,U ; #2~5
+ (fig-forth-auto680):01525 * PULS Y,PC ; #2~9
+ (fig-forth-auto680):01526 * From the 6800 model:
+ (fig-forth-auto680):01527 * CMOVE FDB *+2 takes ( 43+47*count cycles ) on 6800
+ (fig-forth-auto680):01528 * LDX #N
+ (fig-forth-auto680):01529 * LDB #6
+ (fig-forth-auto680):01530 * CMOV1 PULS A ;
+ (fig-forth-auto680):01531 * STA 0,X move parameters to scratch area
+ (fig-forth-auto680):01532 * LEAX 1,X ;
+ (fig-forth-auto680):01533 * DECB ;
+ (fig-forth-auto680):01534 * BNE CMOV1
+ (fig-forth-auto680):01535 * CMOV2 LDA N
+ (fig-forth-auto680):01536 * LDB N+1
+ (fig-forth-auto680):01537 * SUBB #1
+ (fig-forth-auto680):01538 * SBCA #0
+ (fig-forth-auto680):01539 * STA N
+ (fig-forth-auto680):01540 * STB N+1
+ (fig-forth-auto680):01541 * BCS CMOV3
+ (fig-forth-auto680):01542 * LDX N+4
+ (fig-forth-auto680):01543 * LDA 0,X
+ (fig-forth-auto680):01544 * LEAX 1,X ;
+ (fig-forth-auto680):01545 * STX N+4
+ (fig-forth-auto680):01546 * LDX N+2
+ (fig-forth-auto680):01547 * STA 0,X
+ (fig-forth-auto680):01548 * LEAX 1,X ;
+ (fig-forth-auto680):01549 * STX N+2
+ (fig-forth-auto680):01550 * BRA CMOV2
+ (fig-forth-auto680):01551 * CMOV3 JMP NEXT
+ (fig-forth-auto680):01552 *
+ (fig-forth-auto680):01553 * ######>> screen 23 <<
+ (fig-forth-auto680):01554 * ======>> 18 <<
+ (fig-forth-auto680):01555 * ( u1 u2 --- ud )
+ (fig-forth-auto680):01556 * Multiplies the top two unsigned integers,
+ (fig-forth-auto680):01557 * yielding a double integer product.
+15A0 82 (fig-forth-auto680):01558 FCB $82
+15A1 55 (fig-forth-auto680):01559 FCC 'U' ; 'U*'
+15A2 AA (fig-forth-auto680):01560 FCB $AA
+15A3 157C (fig-forth-auto680):01561 FDB CMOVE-8
+15A5 15A7 (fig-forth-auto680):01562 USTAR FDB *+NATWID
+15A7 335C (fig-forth-auto680):01563 LEAU -2*NATWID,U
+15A9 A645 (fig-forth-auto680):01564 LDA 2*NATWID+1,U ; least
+15AB E647 (fig-forth-auto680):01565 LDB 3*NATWID+1,U
+15AD 3D (fig-forth-auto680):01566 MUL
+15AE ED42 (fig-forth-auto680):01567 STD NATWID,U
+15B0 A644 (fig-forth-auto680):01568 LDA 2*NATWID,U ; most
+15B2 E646 (fig-forth-auto680):01569 LDB 3*NATWID,U
+15B4 3D (fig-forth-auto680):01570 MUL
+15B5 EDC4 (fig-forth-auto680):01571 STD ,U
+15B7 EC45 (fig-forth-auto680):01572 LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi)
+15B9 3D (fig-forth-auto680):01573 MUL
+15BA E341 (fig-forth-auto680):01574 ADDD 1,U
+15BC 2402 (fig-forth-auto680):01575 BCC USTAR3
+15BE 6CC4 (fig-forth-auto680):01576 INC ,U
+15C0 ED41 (fig-forth-auto680):01577 USTAR3 STD 1,U
+15C2 A644 (fig-forth-auto680):01578 LDA 2*NATWID,U ; second inner (u2 hi)
+15C4 E646 (fig-forth-auto680):01579 LDB 3*NATWID,U ; (u1 lo)
+15C6 3D (fig-forth-auto680):01580 MUL
+15C7 E341 (fig-forth-auto680):01581 ADDD 1,U
+15C9 2402 (fig-forth-auto680):01582 BCC USTAR4
+15CB 6CC4 (fig-forth-auto680):01583 INC ,U
+15CD ED41 (fig-forth-auto680):01584 USTAR4 STD 1,U
+15CF 3716 (fig-forth-auto680):01585 PULU D,X
+15D1 EDC4 (fig-forth-auto680):01586 STD ,U
+15D3 AF42 (fig-forth-auto680):01587 STX NATWID,U
+15D5 39 (fig-forth-auto680):01588 RTS
+ (fig-forth-auto680):01589 *
+ (fig-forth-auto680):01590 * from 6800 model:
+ (fig-forth-auto680):01591 * BSR USTARS
+ (fig-forth-auto680):01592 * LEAS 1,S ;
+ (fig-forth-auto680):01593 * LEAS 1,S ;
+ (fig-forth-auto680):01594 * JMP PUSHBA
+ (fig-forth-auto680):01595 *
+ (fig-forth-auto680):01596 * The following is a subroutine which
+ (fig-forth-auto680):01597 * multiplies top 2 words on stack,
+ (fig-forth-auto680):01598 * leaving 32-bit result: high order word in A,B
+ (fig-forth-auto680):01599 * low order word in 2nd word of stack.
+ (fig-forth-auto680):01600 *
+ (fig-forth-auto680):01601 * USTARS LDA #16 bits/word counter
+ (fig-forth-auto680):01602 * PSHS A ;
+ (fig-forth-auto680):01603 * CLRA ;
+ (fig-forth-auto680):01604 * CLRB ;
+ (fig-forth-auto680):01605 * TFR S,X ; TSX :
+ (fig-forth-auto680):01606 * USTAR2 ROR 5,X shift multiplier
+ (fig-forth-auto680):01607 * ROR 6,X
+ (fig-forth-auto680):01608 * DEC 0,X done?
+ (fig-forth-auto680):01609 * BMI USTAR4
+ (fig-forth-auto680):01610 * BCC USTAR3
+ (fig-forth-auto680):01611 * ADDB 4,X
+ (fig-forth-auto680):01612 * ADCA 3,X
+ (fig-forth-auto680):01613 * USTAR3 RORA ;
+ (fig-forth-auto680):01614 * RORB ; shift result
+ (fig-forth-auto680):01615 * BRA USTAR2
+ (fig-forth-auto680):01616 * USTAR4 LEAS 1,S ; dump counter
+ (fig-forth-auto680):01617 * RTS
+ (fig-forth-auto680):01618 *
+ (fig-forth-auto680):01619 * ######>> screen 24 <<
+ (fig-forth-auto680):01620 * ======>> 19 <<
+ (fig-forth-auto680):01621 * ( ud u --- uremainder uquotient )
+ (fig-forth-auto680):01622 * Divides the top unsigned integer
+ (fig-forth-auto680):01623 * into the second and third words on the stack
+ (fig-forth-auto680):01624 * as a single unsigned double integer,
+ (fig-forth-auto680):01625 * leaving the remainder and quotient (quotient on top)
+ (fig-forth-auto680):01626 * as unsigned integers.
+ (fig-forth-auto680):01627 *
+ (fig-forth-auto680):01628 * The smaller the divisor, the more likely dropping the high word
+ (fig-forth-auto680):01629 * of the quotient loses significant bits. See M/MOD .
+ (fig-forth-auto680):01630 *
+15D6 82 (fig-forth-auto680):01631 FCB $82
+15D7 55 (fig-forth-auto680):01632 FCC 'U' ; 'U/'
+15D8 AF (fig-forth-auto680):01633 FCB $AF
+15D9 15A0 (fig-forth-auto680):01634 FDB USTAR-5
+15DB 15DD (fig-forth-auto680):01635 USLASH FDB *+NATWID
+15DD 8611 (fig-forth-auto680):01636 LDA #17 ; bit ct
+15DF 3402 (fig-forth-auto680):01637 PSHS A
+15E1 EC42 (fig-forth-auto680):01638 LDD NATWID,U ; dividend
+15E3 10A3C4 (fig-forth-auto680):01639 USLDIV CMPD ,U ; divisor
+15E6 2404 (fig-forth-auto680):01640 BHS USLSUB
+15E8 1CFE (fig-forth-auto680):01641 ANDCC #~1 ; carry clear
+15EA 2004 (fig-forth-auto680):01642 BRA USLBIT
+15EC A3C4 (fig-forth-auto680):01643 USLSUB SUBD ,U
+15EE 1A01 (fig-forth-auto680):01644 ORCC #1 ; quotient, (carry set)
+15F0 6945 (fig-forth-auto680):01645 USLBIT ROL 2*NATWID+1,U ; save it
+15F2 6944 (fig-forth-auto680):01646 ROL 2*NATWID,U
+15F4 6AE4 (fig-forth-auto680):01647 DEC ,S ; more bits?
+15F6 2706 (fig-forth-auto680):01648 BEQ USLR
+15F8 59 (fig-forth-auto680):01649 ROLB ; remainder
+15F9 49 (fig-forth-auto680):01650 ROLA
+15FA 24E7 (fig-forth-auto680):01651 BCC USLDIV
+15FC 20EE (fig-forth-auto680):01652 BRA USLSUB
+15FE 3342 (fig-forth-auto680):01653 USLR LEAU NATWID,U
+1600 AE42 (fig-forth-auto680):01654 LDX NATWID,U
+1602 ED42 (fig-forth-auto680):01655 STD NATWID,U
+1604 AFC4 (fig-forth-auto680):01656 STX ,U
+1606 3582 (fig-forth-auto680):01657 PULS A,PC ; Avoiding a LEAS 1,S by discarding A.
+ (fig-forth-auto680):01658 *
+ (fig-forth-auto680):01659 * from 6800 model:
+ (fig-forth-auto680):01660 * LDA #17
+ (fig-forth-auto680):01661 * PSHS A ;
+ (fig-forth-auto680):01662 * TFR S,X ; TSX :
+ (fig-forth-auto680):01663 * LDA 3,X
+ (fig-forth-auto680):01664 * LDB 4,X
+ (fig-forth-auto680):01665 * USL1 CMPA 1,X
+ (fig-forth-auto680):01666 * BHI USL3
+ (fig-forth-auto680):01667 * BCS USL2
+ (fig-forth-auto680):01668 * CMPB 2,X
+ (fig-forth-auto680):01669 * BCC USL3
+ (fig-forth-auto680):01670 * USL2 ANDCC #~$01 ; CLC :
+ (fig-forth-auto680):01671 * BRA USL4
+ (fig-forth-auto680):01672 * USL3 SUBB 2,X
+ (fig-forth-auto680):01673 * SBCA 1,X
+ (fig-forth-auto680):01674 * ORCC #$01 ; SEC :
+ (fig-forth-auto680):01675 * USL4 ROL 6,X
+ (fig-forth-auto680):01676 * ROL 5,X
+ (fig-forth-auto680):01677 * DEC 0,X
+ (fig-forth-auto680):01678 * BEQ USL5
+ (fig-forth-auto680):01679 * ROLB ;
+ (fig-forth-auto680):01680 * ROLA ;
+ (fig-forth-auto680):01681 * BCC USL1
+ (fig-forth-auto680):01682 * BRA USL3
+ (fig-forth-auto680):01683 * USL5 LEAS 1,S ;
+ (fig-forth-auto680):01684 * LEAS 1,S ;
+ (fig-forth-auto680):01685 * LEAS 1,S ;
+ (fig-forth-auto680):01686 * LEAS 1,S ;
+ (fig-forth-auto680):01687 * LEAS 1,S ;
+ (fig-forth-auto680):01688 * JMP SWAP+4 reverse quotient & remainder
+ (fig-forth-auto680):01689 *
+ (fig-forth-auto680):01690 * ######>> screen 25 <<
+ (fig-forth-auto680):01691 * ======>> 20 <<
+ (fig-forth-auto680):01692 * ( n1 n2 --- n )
+ (fig-forth-auto680):01693 * Bitwise and the top two integers.
+1608 83 (fig-forth-auto680):01694 FCB $83
+1609 414E (fig-forth-auto680):01695 FCC 'AN' ; 'AND'
+160B C4 (fig-forth-auto680):01696 FCB $C4
+160C 15D6 (fig-forth-auto680):01697 FDB USLASH-5
+160E 1610 (fig-forth-auto680):01698 AND FDB *+NATWID
+1610 3706 (fig-forth-auto680):01699 PULU A,B
+1612 E441 (fig-forth-auto680):01700 ANDB 1,U
+1614 A4C4 (fig-forth-auto680):01701 ANDA ,U
+1616 EDC4 (fig-forth-auto680):01702 STD ,U
+1618 39 (fig-forth-auto680):01703 RTS
+ (fig-forth-auto680):01704 * PULS A ;
+ (fig-forth-auto680):01705 * PULS B ;
+ (fig-forth-auto680):01706 * TFR S,X ; TSX :
+ (fig-forth-auto680):01707 * ANDB 1,X
+ (fig-forth-auto680):01708 * ANDA 0,X
+ (fig-forth-auto680):01709 * JMP STABX
+ (fig-forth-auto680):01710 *
+ (fig-forth-auto680):01711 * ======>> 21 <<
+ (fig-forth-auto680):01712 * ( n1 n2 --- n )
+ (fig-forth-auto680):01713 * Bitwise or the top two integers.
+1619 82 (fig-forth-auto680):01714 FCB $82
+161A 4F (fig-forth-auto680):01715 FCC 'O' ; 'OR'
+161B D2 (fig-forth-auto680):01716 FCB $D2
+161C 1608 (fig-forth-auto680):01717 FDB AND-6
+161E 1620 (fig-forth-auto680):01718 OR FDB *+NATWID
+1620 3706 (fig-forth-auto680):01719 PULU A,B
+1622 EA41 (fig-forth-auto680):01720 ORB 1,U
+1624 AAC4 (fig-forth-auto680):01721 ORA ,U
+1626 EDC4 (fig-forth-auto680):01722 STD ,U
+1628 39 (fig-forth-auto680):01723 RTS
+ (fig-forth-auto680):01724 * PULS A ;
+ (fig-forth-auto680):01725 * PULS B ;
+ (fig-forth-auto680):01726 * TFR S,X ; TSX :
+ (fig-forth-auto680):01727 * ORB 1,X
+ (fig-forth-auto680):01728 * ORA 0,X
+ (fig-forth-auto680):01729 * JMP STABX
+ (fig-forth-auto680):01730 *
+ (fig-forth-auto680):01731 * ======>> 22 <<
+ (fig-forth-auto680):01732 * ( n1 n2 --- n )
+ (fig-forth-auto680):01733 * Bitwise exclusive or the top two integers.
+1629 83 (fig-forth-auto680):01734 FCB $83
+162A 584F (fig-forth-auto680):01735 FCC 'XO' ; 'XOR'
+162C D2 (fig-forth-auto680):01736 FCB $D2
+162D 1619 (fig-forth-auto680):01737 FDB OR-5
+162F 1631 (fig-forth-auto680):01738 XOR FDB *+NATWID
+1631 3706 (fig-forth-auto680):01739 PULU A,B
+1633 E841 (fig-forth-auto680):01740 EORB 1,U
+1635 A8C4 (fig-forth-auto680):01741 EORA ,U
+1637 EDC4 (fig-forth-auto680):01742 STD ,U
+1639 39 (fig-forth-auto680):01743 RTS
+ (fig-forth-auto680):01744 * PULS A ;
+ (fig-forth-auto680):01745 * PULS B ;
+ (fig-forth-auto680):01746 * TFR S,X ; TSX :
+ (fig-forth-auto680):01747 * EORB 1,X
+ (fig-forth-auto680):01748 * EORA 0,X
+ (fig-forth-auto680):01749 * JMP STABX
+ (fig-forth-auto680):01750 *
+ (fig-forth-auto680):01751 * ######>> screen 26 <<
+ (fig-forth-auto680):01752 * ======>> 23 <<
+ (fig-forth-auto680):01753 * ( --- adr )
+ (fig-forth-auto680):01754 * Fetch the parameter stack pointer (before it is pushed).
+ (fig-forth-auto680):01755 * This points at whatever was on the top of stack before.
+163A 83 (fig-forth-auto680):01756 FCB $83
+163B 5350 (fig-forth-auto680):01757 FCC 'SP' ; 'SP@'
+163D C0 (fig-forth-auto680):01758 FCB $C0
+163E 1629 (fig-forth-auto680):01759 FDB XOR-6
+1640 1642 (fig-forth-auto680):01760 SPAT FDB *+NATWID
+1642 1F31 (fig-forth-auto680):01761 TFR U,X
+1644 3610 (fig-forth-auto680):01762 PSHU X
+1646 39 (fig-forth-auto680):01763 RTS
+ (fig-forth-auto680):01764 * TFR S,X ; TSX :
+ (fig-forth-auto680):01765 * STX N scratch area
+ (fig-forth-auto680):01766 * LDX #N
+ (fig-forth-auto680):01767 * JMP GETX
+ (fig-forth-auto680):01768 *
+ (fig-forth-auto680):01769 * ======>> 24 <<
+ (fig-forth-auto680):01770 * ( whatever --- nothing )
+ (fig-forth-auto680):01771 * Initialize the parameter stack pointer from the USER variable S0.
+ (fig-forth-auto680):01772 * Effectively clears the stack.
+1647 83 (fig-forth-auto680):01773 FCB $83
+1648 5350 (fig-forth-auto680):01774 FCC 'SP' ; 'SP!'
+164A A1 (fig-forth-auto680):01775 FCB $A1
+164B 163A (fig-forth-auto680):01776 FDB SPAT-6
+164D 164F (fig-forth-auto680):01777 SPSTOR FDB *+NATWID
+164F DE1E (fig-forth-auto680):01778 LDU <XSPZER
+1651 39 (fig-forth-auto680):01779 RTS
+ (fig-forth-auto680):01780 * LDX UP
+ (fig-forth-auto680):01781 * LDX XSPZER-UORIG,X
+ (fig-forth-auto680):01782 * TFR X,S ; TXS : watch it ! X and S are not equal on 6800.
+ (fig-forth-auto680):01783 * JMP NEXT
+ (fig-forth-auto680):01784 * ======>> 25 <<
+ (fig-forth-auto680):01785 * ( whatever *** nothing )
+ (fig-forth-auto680):01786 * Initialize the return stack pointer from the initialization table
+ (fig-forth-auto680):01787 * instead of the user variable R0, for some reason.
+ (fig-forth-auto680):01788 * Quite possibly, this should be from R0.
+ (fig-forth-auto680):01789 * Effectively aborts all in process definitions, except the active one.
+ (fig-forth-auto680):01790 * An emergency measure, to be sure.
+ (fig-forth-auto680):01791 * The routine that calls this must never execute a return.
+ (fig-forth-auto680):01792 * So this should never be executed from the terminal, I guess.
+ (fig-forth-auto680):01793 * This is another that should be compile-time only, and in a separate vocabulary.
+1652 83 (fig-forth-auto680):01794 FCB $83
+1653 5250 (fig-forth-auto680):01795 FCC 'RP' ; 'RP!'
+1655 A1 (fig-forth-auto680):01796 FCB $A1
+1656 1647 (fig-forth-auto680):01797 FDB SPSTOR-6
+1658 165A (fig-forth-auto680):01798 RPSTOR FDB *+NATWID
+165A 3510 (fig-forth-auto680):01799 PULS X ; But this guy has to return to his caller.
+165C 10FE1214 (fig-forth-auto680):01800 LDS RINIT
+1660 6E84 (fig-forth-auto680):01801 JMP ,X
+ (fig-forth-auto680):01802 * LDX RINIT initialize from rom constant
+ (fig-forth-auto680):01803 * STX RP
+ (fig-forth-auto680):01804 * JMP NEXT
+ (fig-forth-auto680):01805 *
+ (fig-forth-auto680):01806 * ======>> 26 <<
+ (fig-forth-auto680):01807 * ( ip *** )
+ (fig-forth-auto680):01808 * Pop IP from return stack (return from high-level definition).
+ (fig-forth-auto680):01809 * Can be used in a screen to force interpretion to terminate.
+ (fig-forth-auto680):01810 * Must not be executed when temporaries are saved on top of the return stack.
+1662 82 (fig-forth-auto680):01811 FCB $82
+1663 3B (fig-forth-auto680):01812 FCC ';' ; ';S'
+1664 D3 (fig-forth-auto680):01813 FCB $D3
+1665 1652 (fig-forth-auto680):01814 FDB RPSTOR-6
+1667 1669 (fig-forth-auto680):01815 SEMIS FDB *+NATWID
+1669 3526 (fig-forth-auto680):01816 PULS D,Y ; return address in D, and saved IP in Y.
+166B 1F05 (fig-forth-auto680):01817 TFR D,PC ; Synthetic return.
+ (fig-forth-auto680):01818 *
+ (fig-forth-auto680):01819 * Form 6800 model:
+ (fig-forth-auto680):01820 * LDX RP
+ (fig-forth-auto680):01821 * LEAX 1,X ;
+ (fig-forth-auto680):01822 * LEAX 1,X ;
+ (fig-forth-auto680):01823 * STX RP
+ (fig-forth-auto680):01824 * LDX 0,X get address we have just finished.
+ (fig-forth-auto680):01825 * JMP NEXT+2 increment the return address & do next word
+ (fig-forth-auto680):01826 *
+ (fig-forth-auto680):01827 * ######>> screen 27 <<
+ (fig-forth-auto680):01828 * ======>> 27 <<
+ (fig-forth-auto680):01829 * ( limit index *** index index )
+ (fig-forth-auto680):01830 * Force the terminating condition for the innermost loop by
+ (fig-forth-auto680):01831 * copying its index to its limit.
+ (fig-forth-auto680):01832 * Termination is postponed until the next
+ (fig-forth-auto680):01833 * LOOP or +LOOP instruction is executed.
+ (fig-forth-auto680):01834 * The index remains available for use until
+ (fig-forth-auto680):01835 * the LOOP or +LOOP instruction is encountered.
+ (fig-forth-auto680):01836 * Note that the assumption is that the current count is the correct count
+ (fig-forth-auto680):01837 * to end at, rather than pushing the count to the final count.
+166D 85 (fig-forth-auto680):01838 FCB $85
+166E 4C454156 (fig-forth-auto680):01839 FCC 'LEAV' ; 'LEAVE'
+1672 C5 (fig-forth-auto680):01840 FCB $C5
+1673 1662 (fig-forth-auto680):01841 FDB SEMIS-5
+1675 1677 (fig-forth-auto680):01842 LEAVE FDB *+NATWID
+1677 EC62 (fig-forth-auto680):01843 LDD NATWID,S ; Dodge the return address.
+1679 ED64 (fig-forth-auto680):01844 STD 2*NATWID,S
+167B 39 (fig-forth-auto680):01845 RTS
+ (fig-forth-auto680):01846 * LDX RP
+ (fig-forth-auto680):01847 * LDA 2,X
+ (fig-forth-auto680):01848 * LDB 3,X
+ (fig-forth-auto680):01849 * STA 4,X
+ (fig-forth-auto680):01850 * STB 5,X
+ (fig-forth-auto680):01851 * JMP NEXT
+ (fig-forth-auto680):01852 *
+ (fig-forth-auto680):01853 * ======>> 28 <<
+ (fig-forth-auto680):01854 * ( n --- )
+ (fig-forth-auto680):01855 * ( *** n )
+ (fig-forth-auto680):01856 * Move top of parameter stack to top of return stack.
+167C 82 (fig-forth-auto680):01857 FCB $82
+167D 3E (fig-forth-auto680):01858 FCC '>' ; '>R'
+167E D2 (fig-forth-auto680):01859 FCB $D2
+167F 166D (fig-forth-auto680):01860 FDB LEAVE-8
+1681 1683 (fig-forth-auto680):01861 TOR FDB *+NATWID
+1683 3706 (fig-forth-auto680):01862 PULU A,B
+1685 AEE4 (fig-forth-auto680):01863 LDX ,S
+1687 EDE4 (fig-forth-auto680):01864 STD ,S ; Put it where the return address was.
+1689 6E84 (fig-forth-auto680):01865 JMP ,X
+ (fig-forth-auto680):01866 * LDX RP
+ (fig-forth-auto680):01867 * LEAX -1,X ;
+ (fig-forth-auto680):01868 * LEAX -1,X ;
+ (fig-forth-auto680):01869 * STX RP
+ (fig-forth-auto680):01870 * PULS A ;
+ (fig-forth-auto680):01871 * PULS B ;
+ (fig-forth-auto680):01872 * STA 2,X
+ (fig-forth-auto680):01873 * STB 3,X
+ (fig-forth-auto680):01874 * JMP NEXT
+ (fig-forth-auto680):01875 *
+ (fig-forth-auto680):01876 * ======>> 29 <<
+ (fig-forth-auto680):01877 * ( --- n )
+ (fig-forth-auto680):01878 * ( n *** )
+ (fig-forth-auto680):01879 * Move top of return stack to top of parameter stack.
+168B 82 (fig-forth-auto680):01880 FCB $82
+168C 52 (fig-forth-auto680):01881 FCC 'R' ; 'R>'
+168D BE (fig-forth-auto680):01882 FCB $BE
+168E 167C (fig-forth-auto680):01883 FDB TOR-5
+1690 1692 (fig-forth-auto680):01884 FROMR FDB *+NATWID
+1692 3516 (fig-forth-auto680):01885 PULS D,X
+1694 3610 (fig-forth-auto680):01886 PSHU X
+1696 1F05 (fig-forth-auto680):01887 TFR D,PC
+ (fig-forth-auto680):01888 * LDX RP
+ (fig-forth-auto680):01889 * LDA 2,X
+ (fig-forth-auto680):01890 * LDB 3,X
+ (fig-forth-auto680):01891 * LEAX 1,X ;
+ (fig-forth-auto680):01892 * LEAX 1,X ;
+ (fig-forth-auto680):01893 * STX RP
+ (fig-forth-auto680):01894 * JMP PUSHBA
+ (fig-forth-auto680):01895 *
+ (fig-forth-auto680):01896 * ======>> 30 <<
+ (fig-forth-auto680):01897 * ( --- n )
+ (fig-forth-auto680):01898 * ( n *** n )
+ (fig-forth-auto680):01899 * Copy the top of return stack to top of parameter stack.
+ (fig-forth-auto680):01900 * A synonym for I.
+1698 81 (fig-forth-auto680):01901 FCB $81 R
+1699 D2 (fig-forth-auto680):01902 FCB $D2
+169A 168B (fig-forth-auto680):01903 FDB FROMR-5
+169C 1467 (fig-forth-auto680):01904 R FDB I+NATWID
+ (fig-forth-auto680):01905
+ (fig-forth-auto680):01906 * LDX RP
+ (fig-forth-auto680):01907 * LEAX 1,X ;
+ (fig-forth-auto680):01908 * LEAX 1,X ;
+ (fig-forth-auto680):01909 * JMP GETX
+ (fig-forth-auto680):01910 *
+ (fig-forth-auto680):01911 * ######>> screen 28 <<
+ (fig-forth-auto680):01912 * ======>> 31 <<
+ (fig-forth-auto680):01913 * ( n --- n=0 )
+ (fig-forth-auto680):01914 * Logically invert top of stack;
+ (fig-forth-auto680):01915 * or flag true if top is zero, otherwise false.
+169E 82 (fig-forth-auto680):01916 FCB $82
+169F 30 (fig-forth-auto680):01917 FCC '0' ; '0='
+16A0 BD (fig-forth-auto680):01918 FCB $BD
+16A1 1698 (fig-forth-auto680):01919 FDB R-4
+16A3 16A5 (fig-forth-auto680):01920 ZEQU FDB *+NATWID
+16A5 CC0000 (fig-forth-auto680):01921 LDD #0
+16A8 AEC4 (fig-forth-auto680):01922 LDX ,U
+16AA 2601 (fig-forth-auto680):01923 BNE ZEQUF
+16AC 5C (fig-forth-auto680):01924 INCB ; 1 is true
+16AD EDC4 (fig-forth-auto680):01925 ZEQUF STD ,U
+16AF 39 (fig-forth-auto680):01926 RTS
+ (fig-forth-auto680):01927 * TFR S,X ; TSX :
+ (fig-forth-auto680):01928 * CLRA ;
+ (fig-forth-auto680):01929 * CLRB ;
+ (fig-forth-auto680):01930 * LDX 0,X
+ (fig-forth-auto680):01931 * BNE ZEQU2
+ (fig-forth-auto680):01932 * INCB ;
+ (fig-forth-auto680):01933 *ZEQU2 TFR S,X ; TSX :
+ (fig-forth-auto680):01934 * JMP STABX
+ (fig-forth-auto680):01935 *
+ (fig-forth-auto680):01936 * ======>> 32 <<
+ (fig-forth-auto680):01937 * ( n --- n<0 )
+ (fig-forth-auto680):01938 * Flag true if top is negative (MSbit set), otherwise false.
+16B0 82 (fig-forth-auto680):01939 FCB $82
+16B1 30 (fig-forth-auto680):01940 FCC '0' ; '0<'
+16B2 BC (fig-forth-auto680):01941 FCB $BC
+16B3 169E (fig-forth-auto680):01942 FDB ZEQU-5
+16B5 16B7 (fig-forth-auto680):01943 ZLESS FDB *+NATWID
+16B7 CC0000 (fig-forth-auto680):01944 LDD #0
+16BA 6DC4 (fig-forth-auto680):01945 TST ,U
+16BC 2A01 (fig-forth-auto680):01946 BPL ZLESSF
+16BE 5C (fig-forth-auto680):01947 INCB
+16BF EDC4 (fig-forth-auto680):01948 ZLESSF STD ,U
+16C1 39 (fig-forth-auto680):01949 RTS
+ (fig-forth-auto680):01950 * TFR S,X ; TSX :
+ (fig-forth-auto680):01951 * LDA #$80 check the sign bit
+ (fig-forth-auto680):01952 * ANDA 0,X
+ (fig-forth-auto680):01953 * BEQ ZLESS2
+ (fig-forth-auto680):01954 * CLRA ; if neg.
+ (fig-forth-auto680):01955 * LDB #1
+ (fig-forth-auto680):01956 * JMP STABX
+ (fig-forth-auto680):01957 * ZLESS2 CLRB ;
+ (fig-forth-auto680):01958 * JMP STABX
+ (fig-forth-auto680):01959 *
+ (fig-forth-auto680):01960 * ######>> screen 29 <<
+ (fig-forth-auto680):01961 * ======>> 33 <<
+ (fig-forth-auto680):01962 * ( n1 n2 --- n1+n2 )
+ (fig-forth-auto680):01963 * Add top two words.
+16C2 81 (fig-forth-auto680):01964 FCB $81 '+'
+16C3 AB (fig-forth-auto680):01965 FCB $AB
+16C4 16B0 (fig-forth-auto680):01966 FDB ZLESS-5
+16C6 16C8 (fig-forth-auto680):01967 PLUS FDB *+NATWID
+16C8 3706 (fig-forth-auto680):01968 PULU A,B ; #2~7
+16CA E3C4 (fig-forth-auto680):01969 ADDD ,U ; #2~6
+16CC EDC4 (fig-forth-auto680):01970 STD ,U ; #2~5
+16CE 39 (fig-forth-auto680):01971 RTS ; #1~5 =#7~23
+ (fig-forth-auto680):01972 * PULS A ;
+ (fig-forth-auto680):01973 * PULS B ;
+ (fig-forth-auto680):01974 * TFR S,X ; TSX :
+ (fig-forth-auto680):01975 * ADDB 1,X
+ (fig-forth-auto680):01976 * ADCA 0,X
+ (fig-forth-auto680):01977 * JMP STABX
+ (fig-forth-auto680):01978 *
+ (fig-forth-auto680):01979 * ======>> 34 <<
+ (fig-forth-auto680):01980 * ( d1 d2 --- d1+d2 )
+ (fig-forth-auto680):01981 * Add top two double integers.
+16CF 82 (fig-forth-auto680):01982 FCB $82
+16D0 44 (fig-forth-auto680):01983 FCC 'D' ; 'D+'
+16D1 AB (fig-forth-auto680):01984 FCB $AB
+16D2 16C2 (fig-forth-auto680):01985 FDB PLUS-4
+16D4 16D6 (fig-forth-auto680):01986 DPLUS FDB *+NATWID
+16D6 EC46 (fig-forth-auto680):01987 LDD 3*NATWID,U
+16D8 E342 (fig-forth-auto680):01988 ADDD NATWID,U
+16DA ED46 (fig-forth-auto680):01989 STD 3*NATWID,U
+16DC EC44 (fig-forth-auto680):01990 LDD 2*NATWID,U
+16DE E941 (fig-forth-auto680):01991 ADCB 1,U
+16E0 A9C4 (fig-forth-auto680):01992 ADCA ,U
+16E2 3344 (fig-forth-auto680):01993 LEAU 2*NATWID,U
+16E4 EDC4 (fig-forth-auto680):01994 STD ,U
+16E6 39 (fig-forth-auto680):01995 RTS
+ (fig-forth-auto680):01996 * TFR S,X ; TSX :
+ (fig-forth-auto680):01997 * ANDCC #~$01 ; CLC :
+ (fig-forth-auto680):01998 * LDB #4
+ (fig-forth-auto680):01999 * DPLUS2 LDA 3,X
+ (fig-forth-auto680):02000 * ADCA 7,X
+ (fig-forth-auto680):02001 * STA 7,X
+ (fig-forth-auto680):02002 * LEAX -1,X ;
+ (fig-forth-auto680):02003 * DECB ;
+ (fig-forth-auto680):02004 * BNE DPLUS2
+ (fig-forth-auto680):02005 * LEAS 1,S ;
+ (fig-forth-auto680):02006 * LEAS 1,S ;
+ (fig-forth-auto680):02007 * LEAS 1,S ;
+ (fig-forth-auto680):02008 * LEAS 1,S ;
+ (fig-forth-auto680):02009 * JMP NEXT
+ (fig-forth-auto680):02010 *
+ (fig-forth-auto680):02011 * ======>> 35 <<
+ (fig-forth-auto680):02012 * ( n --- -n )
+ (fig-forth-auto680):02013 * Negate (two's complement) top of stack.
+16E7 85 (fig-forth-auto680):02014 FCB $85
+16E8 4D494E55 (fig-forth-auto680):02015 FCC 'MINU' ; 'MINUS'
+16EC D3 (fig-forth-auto680):02016 FCB $D3
+16ED 16CF (fig-forth-auto680):02017 FDB DPLUS-5
+16EF 16F1 (fig-forth-auto680):02018 MINUS FDB *+NATWID
+16F1 CC0000 (fig-forth-auto680):02019 LDD #0 ; #3~3
+16F4 A3C4 (fig-forth-auto680):02020 SUBD ,U ; #2~5
+16F6 EDC4 (fig-forth-auto680):02021 STD ,U ; #2~5
+16F8 39 (fig-forth-auto680):02022 RTS ; #1~5 = #8~18
+ (fig-forth-auto680):02023 *
+ (fig-forth-auto680):02024 * from 6800 model code:
+ (fig-forth-auto680):02025 * TFR S,X ; TSX :
+ (fig-forth-auto680):02026 * NEG 1,X
+ (fig-forth-auto680):02027 * BCC MINUS2
+ (fig-forth-auto680):02028 * NEG 0,X
+ (fig-forth-auto680):02029 * BRA MINUS3
+ (fig-forth-auto680):02030 * MINUS2 COM 0,X
+ (fig-forth-auto680):02031 * MINUS3 JMP NEXT
+ (fig-forth-auto680):02032 *
+ (fig-forth-auto680):02033 * ======>> 36 <<
+ (fig-forth-auto680):02034 * ( d --- -d )
+ (fig-forth-auto680):02035 * Negate (two's complement) top two words on stack as a double integer.
+16F9 86 (fig-forth-auto680):02036 FCB $86
+16FA 444D494E55 (fig-forth-auto680):02037 FCC 'DMINU' ; 'DMINUS'
+16FF D3 (fig-forth-auto680):02038 FCB $D3
+1700 16E7 (fig-forth-auto680):02039 FDB MINUS-8
+1702 1704 (fig-forth-auto680):02040 DMINUS FDB *+NATWID
+1704 CC0000 (fig-forth-auto680):02041 LDD #0 ; #3~3
+1707 A342 (fig-forth-auto680):02042 SUBD NATWID,U ; #2~7
+1709 ED42 (fig-forth-auto680):02043 STD NATWID,U ; #2~7
+170B CC0000 (fig-forth-auto680):02044 LDD #0 ; #3~3
+170E E241 (fig-forth-auto680):02045 SBCB 1,U ; #2~5
+1710 A2C4 (fig-forth-auto680):02046 SBCA ,U ; #2~4
+1712 EDC4 (fig-forth-auto680):02047 STD ,U ; #2~5
+1714 39 (fig-forth-auto680):02048 RTS ; #1~5 = #17~39
+ (fig-forth-auto680):02049 * TFR S,X ; TSX :
+ (fig-forth-auto680):02050 * COM 0,X
+ (fig-forth-auto680):02051 * COM 1,X
+ (fig-forth-auto680):02052 * COM 2,X
+ (fig-forth-auto680):02053 * NEG 3,X
+ (fig-forth-auto680):02054 * BNE DMINX
+ (fig-forth-auto680):02055 * INC 2,X
+ (fig-forth-auto680):02056 * BNE DMINX
+ (fig-forth-auto680):02057 * INC 1,X
+ (fig-forth-auto680):02058 * BNE DMINX
+ (fig-forth-auto680):02059 * INC 0,X
+ (fig-forth-auto680):02060 * DMINX JMP NEXT
+ (fig-forth-auto680):02061 *
+ (fig-forth-auto680):02062 * ######>> screen 30 <<
+ (fig-forth-auto680):02063 * ======>> 37 <<
+ (fig-forth-auto680):02064 * ( n1 n2 --- n1 n2 n1 )
+ (fig-forth-auto680):02065 * Push a copy of the second word on stack.
+1715 84 (fig-forth-auto680):02066 FCB $84
+1716 4F5645 (fig-forth-auto680):02067 FCC 'OVE' ; 'OVER'
+1719 D2 (fig-forth-auto680):02068 FCB $D2
+171A 16F9 (fig-forth-auto680):02069 FDB DMINUS-9
+171C 171E (fig-forth-auto680):02070 OVER FDB *+NATWID
+171E EC42 (fig-forth-auto680):02071 LDD NATWID,U
+1720 3606 (fig-forth-auto680):02072 PSHU D
+1722 39 (fig-forth-auto680):02073 RTS
+ (fig-forth-auto680):02074 * TFR S,X ; TSX :
+ (fig-forth-auto680):02075 * LDA 2,X
+ (fig-forth-auto680):02076 * LDB 3,X
+ (fig-forth-auto680):02077 * JMP PUSHBA
+ (fig-forth-auto680):02078 *
+ (fig-forth-auto680):02079 * ======>> 38 <<
+ (fig-forth-auto680):02080 * ( n --- )
+ (fig-forth-auto680):02081 * Discard the top word on stack.
+1723 84 (fig-forth-auto680):02082 FCB $84
+1724 44524F (fig-forth-auto680):02083 FCC 'DRO' ; 'DROP'
+1727 D0 (fig-forth-auto680):02084 FCB $D0
+1728 1715 (fig-forth-auto680):02085 FDB OVER-7
+172A 172C (fig-forth-auto680):02086 DROP FDB *+NATWID
+172C 3342 (fig-forth-auto680):02087 LEAU NATWID,U
+172E 39 (fig-forth-auto680):02088 RTS
+ (fig-forth-auto680):02089 * LEAS 1,S ;
+ (fig-forth-auto680):02090 * LEAS 1,S ;
+ (fig-forth-auto680):02091 * JMP NEXT
+ (fig-forth-auto680):02092 *
+ (fig-forth-auto680):02093 * ======>> 39 <<
+ (fig-forth-auto680):02094 * ( n1 n2 --- n2 n1 )
+ (fig-forth-auto680):02095 * Swap the top two words on stack.
+172F 84 (fig-forth-auto680):02096 FCB $84
+1730 535741 (fig-forth-auto680):02097 FCC 'SWA' ; 'SWAP'
+1733 D0 (fig-forth-auto680):02098 FCB $D0
+1734 1723 (fig-forth-auto680):02099 FDB DROP-7
+1736 1738 (fig-forth-auto680):02100 SWAP FDB *+NATWID
+1738 3716 (fig-forth-auto680):02101 PULU D,X
+173A 3606 (fig-forth-auto680):02102 PSHU D
+173C 3610 (fig-forth-auto680):02103 PSHU X
+173E 39 (fig-forth-auto680):02104 RTS
+ (fig-forth-auto680):02105 * PULS A ;
+ (fig-forth-auto680):02106 * PULS B ;
+ (fig-forth-auto680):02107 * TFR S,X ; TSX :
+ (fig-forth-auto680):02108 * LDX 0,X
+ (fig-forth-auto680):02109 * LEAS 1,S ;
+ (fig-forth-auto680):02110 * LEAS 1,S ;
+ (fig-forth-auto680):02111 * PSHS B ;
+ (fig-forth-auto680):02112 * PSHS A ;
+ (fig-forth-auto680):02113 * STX N
+ (fig-forth-auto680):02114 * LDX #N
+ (fig-forth-auto680):02115 * JMP GETX
+ (fig-forth-auto680):02116 *
+ (fig-forth-auto680):02117 * ======>> 40 <<
+ (fig-forth-auto680):02118 * ( n1 --- n1 n1 )
+ (fig-forth-auto680):02119 * Push a copy of the top word on stack.
+173F 83 (fig-forth-auto680):02120 FCB $83
+1740 4455 (fig-forth-auto680):02121 FCC 'DU' ; 'DUP'
+1742 D0 (fig-forth-auto680):02122 FCB $D0
+1743 172F (fig-forth-auto680):02123 FDB SWAP-7
+1745 1747 (fig-forth-auto680):02124 DUP FDB *+NATWID
+1747 ECC4 (fig-forth-auto680):02125 LDD ,U
+1749 3606 (fig-forth-auto680):02126 PSHU D
+174B 39 (fig-forth-auto680):02127 RTS
+ (fig-forth-auto680):02128 * PULS A ;
+ (fig-forth-auto680):02129 * PULS B ;
+ (fig-forth-auto680):02130 * PSHS B ;
+ (fig-forth-auto680):02131 * PSHS A ;
+ (fig-forth-auto680):02132 * JMP PUSHBA
+ (fig-forth-auto680):02133 *
+ (fig-forth-auto680):02134 * ######>> screen 31 <<
+ (fig-forth-auto680):02135 * ======>> 41 <<
+ (fig-forth-auto680):02136 * ( n adr --- )
+ (fig-forth-auto680):02137 * Add the second word on stack to the word at the adr on top of stack.
+174C 82 (fig-forth-auto680):02138 FCB $82
+174D 2B (fig-forth-auto680):02139 FCC '+' ; '+!'
+174E A1 (fig-forth-auto680):02140 FCB $A1
+174F 173F (fig-forth-auto680):02141 FDB DUP-6
+1751 1753 (fig-forth-auto680):02142 PSTORE FDB *+NATWID
+1753 3710 (fig-forth-auto680):02143 PULU X
+1755 EC84 (fig-forth-auto680):02144 LDD ,X
+1757 E3C1 (fig-forth-auto680):02145 ADDD ,U++
+1759 ED84 (fig-forth-auto680):02146 STD ,X
+175B 39 (fig-forth-auto680):02147 RTS
+ (fig-forth-auto680):02148 * TFR S,X ; TSX :
+ (fig-forth-auto680):02149 * LDX 0,X
+ (fig-forth-auto680):02150 * LEAS 1,S ;
+ (fig-forth-auto680):02151 * LEAS 1,S ;
+ (fig-forth-auto680):02152 * PULS A ; get stack data
+ (fig-forth-auto680):02153 * PULS B ;
+ (fig-forth-auto680):02154 * ADDB 1,X add & store low byte
+ (fig-forth-auto680):02155 * STB 1,X
+ (fig-forth-auto680):02156 * ADCA 0,X add & store hi byte
+ (fig-forth-auto680):02157 * STA 0,X
+ (fig-forth-auto680):02158 * JMP NEXT
+ (fig-forth-auto680):02159 *
+ (fig-forth-auto680):02160 * ======>> 42 <<
+ (fig-forth-auto680):02161 * ( adr b --- )
+ (fig-forth-auto680):02162 * Exclusive or byte at adr with low byte of top word.
+175C 86 (fig-forth-auto680):02163 FCB $86
+175D 544F47474C (fig-forth-auto680):02164 FCC 'TOGGL' ; 'TOGGLE'
+1762 C5 (fig-forth-auto680):02165 FCB $C5
+1763 174C (fig-forth-auto680):02166 FDB PSTORE-5
+1765 1767 (fig-forth-auto680):02167 TOGGLE FDB *+NATWID
+1767 3716 (fig-forth-auto680):02168 PULU D,X
+1769 E884 (fig-forth-auto680):02169 EORB ,X
+176B E784 (fig-forth-auto680):02170 STB ,X
+176D 39 (fig-forth-auto680):02171 RTS
+ (fig-forth-auto680):02172 * Using the model code would be less likely to introduce bugs,
+ (fig-forth-auto680):02173 * but that would sort-of defeat my purposes here.
+ (fig-forth-auto680):02174 * Anyway, I can borrow from theoretically known good bif-6809 code
+ (fig-forth-auto680):02175 * and it's fewer bytes and much faster code this way.
+ (fig-forth-auto680):02176 * TOGGLE
+ (fig-forth-auto680):02177 * FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
+ (fig-forth-auto680):02178 * FDB SEMIS
+ (fig-forth-auto680):02179 *
+ (fig-forth-auto680):02180 * ######>> screen 32 <<
+ (fig-forth-auto680):02181 * ======>> 43 <<
+ (fig-forth-auto680):02182 * ( adr --- n )
+ (fig-forth-auto680):02183 * Replace address on stack with the word at the address.
+176E 81 (fig-forth-auto680):02184 FCB $81 @
+176F C0 (fig-forth-auto680):02185 FCB $C0
+1770 175C (fig-forth-auto680):02186 FDB TOGGLE-9
+1772 1774 (fig-forth-auto680):02187 AT FDB *+NATWID
+1774 ECD4 (fig-forth-auto680):02188 LDD [,U]
+1776 EDC4 (fig-forth-auto680):02189 STD ,U
+1778 39 (fig-forth-auto680):02190 RTS
+ (fig-forth-auto680):02191 * TFR S,X ; TSX :
+ (fig-forth-auto680):02192 * LDX 0,X get address
+ (fig-forth-auto680):02193 * LEAS 1,S ;
+ (fig-forth-auto680):02194 * LEAS 1,S ;
+ (fig-forth-auto680):02195 * JMP GETX
+ (fig-forth-auto680):02196 *
+ (fig-forth-auto680):02197 * ======>> 44 <<
+ (fig-forth-auto680):02198 * ( adr --- b )
+ (fig-forth-auto680):02199 * Replace address on top of stack with the byte at the address.
+ (fig-forth-auto680):02200 * High byte of result is clear.
+1779 82 (fig-forth-auto680):02201 FCB $82
+177A 43 (fig-forth-auto680):02202 FCC 'C' ; 'C@'
+177B C0 (fig-forth-auto680):02203 FCB $C0
+177C 176E (fig-forth-auto680):02204 FDB AT-4
+177E 1780 (fig-forth-auto680):02205 CAT FDB *+NATWID
+1780 E6D4 (fig-forth-auto680):02206 LDB [,U]
+1782 4F (fig-forth-auto680):02207 CLRA
+1783 EDC4 (fig-forth-auto680):02208 STD ,U
+1785 39 (fig-forth-auto680):02209 RTS
+ (fig-forth-auto680):02210
+ (fig-forth-auto680):02211
+ (fig-forth-auto680):02212 * TFR S,X ; TSX :
+ (fig-forth-auto680):02213 * LDX 0,X
+ (fig-forth-auto680):02214 * CLRA ;
+ (fig-forth-auto680):02215 * LDB 0,X
+ (fig-forth-auto680):02216 * LEAS 1,S ;
+ (fig-forth-auto680):02217 * LEAS 1,S ;
+ (fig-forth-auto680):02218 * JMP PUSHBA
+ (fig-forth-auto680):02219 *
+ (fig-forth-auto680):02220 * ======>> 45 <<
+ (fig-forth-auto680):02221 * ( n adr --- )
+ (fig-forth-auto680):02222 * Store second word on stack at address on top of stack.
+1786 81 (fig-forth-auto680):02223 FCB $81
+1787 A1 (fig-forth-auto680):02224 FCB $A1
+1788 1779 (fig-forth-auto680):02225 FDB CAT-5
+178A 178C (fig-forth-auto680):02226 STORE FDB *+NATWID
+178C EC42 (fig-forth-auto680):02227 LDD NATWID,U
+178E EDD4 (fig-forth-auto680):02228 STD [,U]
+1790 3344 (fig-forth-auto680):02229 LEAU 2*NATWID,U
+1792 39 (fig-forth-auto680):02230 RTS
+ (fig-forth-auto680):02231 * TFR S,X ; TSX :
+ (fig-forth-auto680):02232 * LDX 0,X get address
+ (fig-forth-auto680):02233 * LEAS 1,S ;
+ (fig-forth-auto680):02234 * LEAS 1,S ;
+ (fig-forth-auto680):02235 * JMP PULABX
+ (fig-forth-auto680):02236 *
+ (fig-forth-auto680):02237 * ======>> 46 <<
+ (fig-forth-auto680):02238 * ( b adr --- )
+ (fig-forth-auto680):02239 * Store low byte of second word on stack at address on top of stack.
+ (fig-forth-auto680):02240 * High byte is ignored.
+1793 82 (fig-forth-auto680):02241 FCB $82
+1794 43 (fig-forth-auto680):02242 FCC 'C' ; 'C!'
+1795 A1 (fig-forth-auto680):02243 FCB $A1
+1796 1786 (fig-forth-auto680):02244 FDB STORE-4
+1798 179A (fig-forth-auto680):02245 CSTORE FDB *+NATWID
+179A E643 (fig-forth-auto680):02246 LDB 3,U
+179C E7D4 (fig-forth-auto680):02247 STB [,U]
+179E 3344 (fig-forth-auto680):02248 LEAU 2*NATWID,U
+17A0 39 (fig-forth-auto680):02249 RTS
+ (fig-forth-auto680):02250 * TFR S,X ; TSX :
+ (fig-forth-auto680):02251 * LDX 0,X get address
+ (fig-forth-auto680):02252 * LEAS 1,S ;
+ (fig-forth-auto680):02253 * LEAS 1,S ;
+ (fig-forth-auto680):02254 * LEAS 1,S ;
+ (fig-forth-auto680):02255 * PULS B ;
+ (fig-forth-auto680):02256 * STB 0,X
+ (fig-forth-auto680):02257 * JMP NEXT
+ (fig-forth-auto680):02258 PAGE
+ (fig-forth-auto680):02259 *
+ (fig-forth-auto680):02260 * ######>> screen 33 <<
+ (fig-forth-auto680):02261 * ======>> 47 <<
+ (fig-forth-auto680):02262 * ( --- ) P
+ (fig-forth-auto680):02263 * { : name sundry-activities ; } typical input
+ (fig-forth-auto680):02264 * If executing (not compiling),
+ (fig-forth-auto680):02265 * record the data stack mark in CSP,
+ (fig-forth-auto680):02266 * Set the CONTEXT vocabulary to CURRENT,
+ (fig-forth-auto680):02267 * CREATE a header,
+ (fig-forth-auto680):02268 * set state to compile,
+ (fig-forth-auto680):02269 * and compile the call to the trailing native CPU machine code DOCOL.
+ (fig-forth-auto680):02270 *
+ (fig-forth-auto680):02271 * This would not be hard to flatten to native code.
+ (fig-forth-auto680):02272 * But that's not the purpose of a model.
+17A1 C1 (fig-forth-auto680):02273 FCB $C1 : immediate
+17A2 BA (fig-forth-auto680):02274 FCB $BA
+17A3 1793 (fig-forth-auto680):02275 FDB CSTORE-5
+17A5 17B91B6A1B26194C (fig-forth-auto680):02276 COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
+ 1772193E178A
+17B3 20661BEB (fig-forth-auto680):02277 FDB CREATE,RBRAK
+17B7 1C3A (fig-forth-auto680):02278 FDB PSCODE
+ (fig-forth-auto680):02279
+ (fig-forth-auto680):02280 * Here is the IP pusher for allowing
+ (fig-forth-auto680):02281 * nested words in the virtual machine:
+ (fig-forth-auto680):02282 * ( ;S is the equivalent un-nester )
+ (fig-forth-auto680):02283
+ (fig-forth-auto680):02284 * ( *** oldIP )
+ (fig-forth-auto680):02285 * Characteristic of a colon (:) definition.
+ (fig-forth-auto680):02286 * Begins execution of a high-level definition,
+ (fig-forth-auto680):02287 * i. e., nests the definition and begins processing icodes.
+ (fig-forth-auto680):02288 * Mechanically, it pushes the IP (Y register)
+ (fig-forth-auto680):02289 * and loads the Parameter Field Address of the definition which
+ (fig-forth-auto680):02290 * called it into the IP.
+17B9 ECE4 (fig-forth-auto680):02291 DOCOL LDD ,S ; Save the return address.
+17BB 10AFE4 (fig-forth-auto680):02292 STY ,S ; Nest the old IP.
+17BE 3102 (fig-forth-auto680):02293 LEAY NATWID,X ; W still in X, bump to parameters, load as new IP.
+17C0 1F05 (fig-forth-auto680):02294 TFR D,PC ; synthetic return to interpret.
+ (fig-forth-auto680):02295
+ (fig-forth-auto680):02296 * DOCOL LDX RP make room in the stack
+ (fig-forth-auto680):02297 * LEAX -1,X ;
+ (fig-forth-auto680):02298 * LEAX -1,X ;
+ (fig-forth-auto680):02299 * STX RP
+ (fig-forth-auto680):02300 * LDA IP
+ (fig-forth-auto680):02301 * LDB IP+1
+ (fig-forth-auto680):02302 * STA 2,X Store address of the high level word
+ (fig-forth-auto680):02303 * STB 3,X that we are starting to execute
+ (fig-forth-auto680):02304 * LDX W Get first sub-word of that definition
+ (fig-forth-auto680):02305 * JMP NEXT+2 and execute it
+ (fig-forth-auto680):02306 *
+ (fig-forth-auto680):02307 * ======>> 48 <<
+ (fig-forth-auto680):02308 * ( --- ) P
+ (fig-forth-auto680):02309 * { : name sundry-activities ; } typical input
+ (fig-forth-auto680):02310 * ERROR check data stack against mark in CSP,
+ (fig-forth-auto680):02311 * compile ;S,
+ (fig-forth-auto680):02312 * unSMUDGE LATEST definition,
+ (fig-forth-auto680):02313 * and set state to interpretation.
+17C2 C1 (fig-forth-auto680):02314 FCB $C1 ; imnediate code
+17C3 BB (fig-forth-auto680):02315 FCB $BB
+17C4 17A1 (fig-forth-auto680):02316 FDB COLON-4
+17C6 17B91B921BC71667 (fig-forth-auto680):02317 SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
+ 1BFF1BDD
+17D2 1667 (fig-forth-auto680):02318 FDB SEMIS
+ (fig-forth-auto680):02319 *
+ (fig-forth-auto680):02320 * ######>> screen 34 <<
+ (fig-forth-auto680):02321 * ======>> 49 <<
+ (fig-forth-auto680):02322 * ( n --- )
+ (fig-forth-auto680):02323 * { value CONSTANT name } typical input
+ (fig-forth-auto680):02324 * CREATE a header,
+ (fig-forth-auto680):02325 * unSMUDGE it,
+ (fig-forth-auto680):02326 * compile the constant value,
+ (fig-forth-auto680):02327 * and compile the call to the trailing native CPU machine code DOCON.
+17D4 88 (fig-forth-auto680):02328 FCB $88
+17D5 434F4E5354414E (fig-forth-auto680):02329 FCC 'CONSTAN' ; 'CONSTANT'
+17DC D4 (fig-forth-auto680):02330 FCB $D4
+17DD 17C2 (fig-forth-auto680):02331 FDB SEMI-4
+17DF 17B920661BFF19E3 (fig-forth-auto680):02332 CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
+ 1C3A
+ (fig-forth-auto680):02333 * ( --- n )
+ (fig-forth-auto680):02334 * Characteristic of a CONSTANT.
+ (fig-forth-auto680):02335 * A CONSTANT simply loads its value from its parameter field
+ (fig-forth-auto680):02336 * and pushes it on the stack.
+17E9 EC02 (fig-forth-auto680):02337 DOCON LDD NATWID,X ; Get the first natural width word of the parameter field.
+17EB 3606 (fig-forth-auto680):02338 PSHU D
+17ED 39 (fig-forth-auto680):02339 RTS
+ (fig-forth-auto680):02340 * DOCON LDX W
+ (fig-forth-auto680):02341 * LDA 2,X
+ (fig-forth-auto680):02342 * LDB 3,X A & B now contain the constant
+ (fig-forth-auto680):02343 * JMP PUSHBA
+ (fig-forth-auto680):02344 *
+ (fig-forth-auto680):02345 * Not in model, needed for abstraction:
+ (fig-forth-auto680):02346 * ( --- NATWID )
+ (fig-forth-auto680):02347 * The byte width of objects on stack.
+17EE 86 (fig-forth-auto680):02348 FCB $86
+17EF 4E41545749 (fig-forth-auto680):02349 FCC 'NATWI' ; 'NATWID'
+17F4 C4 (fig-forth-auto680):02350 FCB $C4
+17F5 17D4 (fig-forth-auto680):02351 FDB CON-11
+17F7 17E9 (fig-forth-auto680):02352 NATWC FDB DOCON
+17F9 0002 (fig-forth-auto680):02353 NATWCV FDB NATWID
+ (fig-forth-auto680):02354 *
+ (fig-forth-auto680):02355 * Not in model, needed for abstraction:
+ (fig-forth-auto680):02356 * Note that this is not defined as an INCREMENTER!
+ (fig-forth-auto680):02357 * Coded to increment by the exact constant returned by NATWID
+ (fig-forth-auto680):02358 * ( n --- n+NATWID )
+17FB 84 (fig-forth-auto680):02359 FCB $84
+17FC 4E4154 (fig-forth-auto680):02360 FCC 'NAT' ; 'NAT+'
+17FF AB (fig-forth-auto680):02361 FCB $AB
+1800 17EE (fig-forth-auto680):02362 FDB NATWC-9
+1802 1804 (fig-forth-auto680):02363 NATP FDB *+NATWID
+1804 ECC4 (fig-forth-auto680):02364 LDD ,U
+1806 E38CF0 (fig-forth-auto680):02365 ADDD NATWCV,PCR ; Looking ahead, does not have to be PCRelative.
+1809 EDC4 (fig-forth-auto680):02366 STD ,U
+180B 39 (fig-forth-auto680):02367 RTS
+ (fig-forth-auto680):02368 * How this might have been done for 6800 model:
+ (fig-forth-auto680):02369 * CLRA ; We know the natural width is less than 255, LOL.
+ (fig-forth-auto680):02370 * LDAB NATWCV+1
+ (fig-forth-auto680):02371 * TSX
+ (fig-forth-auto680):02372 * ADDB 1,X
+ (fig-forth-auto680):02373 * ADCA ,X
+ (fig-forth-auto680):02374 * JMP STABX
+ (fig-forth-auto680):02375 *
+ (fig-forth-auto680):02376 * ======>> 50 <<
+ (fig-forth-auto680):02377 * ( init --- )
+ (fig-forth-auto680):02378 * { init VARIABLE name } typical input
+ (fig-forth-auto680):02379 * Use CONSTANT to CREATE a header and compile the initial value, init,
+ (fig-forth-auto680):02380 * then overwrite the characteristic to point to DOVAR.
+180C 88 (fig-forth-auto680):02381 FCB $88
+180D 5641524941424C (fig-forth-auto680):02382 FCC 'VARIABL' ; 'VARIABLE'
+1814 C5 (fig-forth-auto680):02383 FCB $C5
+1815 17FB (fig-forth-auto680):02384 FDB NATP-7
+1817 17B917DF1C3A (fig-forth-auto680):02385 VAR FDB DOCOL,CON,PSCODE
+ (fig-forth-auto680):02386 * ( --- vadr )
+ (fig-forth-auto680):02387 * Characteristic of a VARIABLE.
+ (fig-forth-auto680):02388 * A VARIABLE pushes its PFA address on the stack.
+ (fig-forth-auto680):02389 * The parameter field of a VARIABLE is the actual allocation of the variable,
+ (fig-forth-auto680):02390 * so that pushing its address allows its contents to be @ed (fetched).
+ (fig-forth-auto680):02391 * Ordinary arrays and strings that do not subscript themselves
+ (fig-forth-auto680):02392 * may be allocated by defining a variable
+ (fig-forth-auto680):02393 * and immediately ALLOTting the remaining needed space.
+ (fig-forth-auto680):02394 * VARIABLES are global to all users,
+ (fig-forth-auto680):02395 * and thus should be hidden in resource monitors, but aren't.
+181D 3002 (fig-forth-auto680):02396 DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters.
+181F 3610 (fig-forth-auto680):02397 PSHU X
+1821 39 (fig-forth-auto680):02398 RTS
+ (fig-forth-auto680):02399 * DOVAR LDA W
+ (fig-forth-auto680):02400 * LDB W+1
+ (fig-forth-auto680):02401 * ADDB #2
+ (fig-forth-auto680):02402 * ADCA #0 A,B now contain the address of the variable
+ (fig-forth-auto680):02403 * JMP PUSHBA
+ (fig-forth-auto680):02404 *
+ (fig-forth-auto680):02405 * ======>> 51 <<
+ (fig-forth-auto680):02406 * ( ub --- )
+ (fig-forth-auto680):02407 * { uboffset USER name } typical input
+ (fig-forth-auto680):02408 * CREATE a header and compile the unsigned byte offset in the per-USER table,
+ (fig-forth-auto680):02409 * then overwrite the header with a call to DOUSER.
+ (fig-forth-auto680):02410 * The USER is entirely responsible for maintaining allocation!
+1822 84 (fig-forth-auto680):02411 FCB $84
+1823 555345 (fig-forth-auto680):02412 FCC 'USE' ; 'USER'
+1826 D2 (fig-forth-auto680):02413 FCB $D2
+1827 180C (fig-forth-auto680):02414 FDB VAR-11
+1829 17B917DF1C3A (fig-forth-auto680):02415 USER FDB DOCOL,CON,PSCODE
+ (fig-forth-auto680):02416 * ( --- vadr )
+ (fig-forth-auto680):02417 * Characteristic of a per-USER variable.
+ (fig-forth-auto680):02418 * USER variables are similiar to VARIABLEs,
+ (fig-forth-auto680):02419 * but are allocated (by hand!) in the per-user table.
+ (fig-forth-auto680):02420 * A USER variable's parameter field contains its offset in the per-user table.
+182F 1FB8 (fig-forth-auto680):02421 DOUSER TFR DP,A ; Make a pointer to the direct page.
+1831 5F (fig-forth-auto680):02422 CLRB
+ (fig-forth-auto680):02423 * See Alternative -- alternatives start from this point.
+1832 E302 (fig-forth-auto680):02424 ADDD NATWID,X ; Add it to the offset to the per-user variable.
+1834 3606 (fig-forth-auto680):02425 PSHU D
+1836 1F01 (fig-forth-auto680):02426 TFR D,X ; Cache the pointer in X for the caller.
+1838 39 (fig-forth-auto680):02427 RTS
+ (fig-forth-auto680):02428 * Hey, the per-user table could actually be larger than 256 bytes!
+ (fig-forth-auto680):02429 * But we knew that. It's just not as esthetic to calculate it this way.
+ (fig-forth-auto680):02430 * Alternative A:
+ (fig-forth-auto680):02431 * LDX NATWID,X ; Keep the offset
+ (fig-forth-auto680):02432 * EXG D,X ; Prepare for EA
+ (fig-forth-auto680):02433 * LEAX D,X
+ (fig-forth-auto680):02434 * PSHU X
+ (fig-forth-auto680):02435 * RTS
+ (fig-forth-auto680):02436 * Alternative B:
+ (fig-forth-auto680):02437 * PSHS Y ; Get Y free for calculations.
+ (fig-forth-auto680):02438 * TFR D,Y ; Y points to the UP base
+ (fig-forth-auto680):02439 * LDD NATWID,X ; Get the offset
+ (fig-forth-auto680):02440 * LEAX D,Y ; Leave the pointer cached in X.
+ (fig-forth-auto680):02441 * PSHU X
+ (fig-forth-auto680):02442 * PULS Y,PC
+ (fig-forth-auto680):02443 *
+ (fig-forth-auto680):02444 * From the 6800 model:
+ (fig-forth-auto680):02445 * DOUSER LDX W get offset into user's table
+ (fig-forth-auto680):02446 * LDA 2,X
+ (fig-forth-auto680):02447 * LDB 3,X
+ (fig-forth-auto680):02448 * ADDB UP+1 add to users base address
+ (fig-forth-auto680):02449 * ADCA UP
+ (fig-forth-auto680):02450 * JMP PUSHBA push address of user's variable
+ (fig-forth-auto680):02451 *
+ (fig-forth-auto680):02452 * ######>> screen 35 <<
+ (fig-forth-auto680):02453 * ======>> 52 <<
+ (fig-forth-auto680):02454 * ( --- 0 )
+1839 81 (fig-forth-auto680):02455 FCB $81
+183A B0 (fig-forth-auto680):02456 FCB $B0 0
+183B 1822 (fig-forth-auto680):02457 FDB USER-7
+183D 17E9 (fig-forth-auto680):02458 ZERO FDB DOCON
+183F 0000 (fig-forth-auto680):02459 FDB 0000
+ (fig-forth-auto680):02460 *
+ (fig-forth-auto680):02461 * ======>> 53 <<
+ (fig-forth-auto680):02462 * ( --- 1 )
+1841 81 (fig-forth-auto680):02463 FCB $81
+1842 B1 (fig-forth-auto680):02464 FCB $B1 1
+1843 1839 (fig-forth-auto680):02465 FDB ZERO-4
+1845 17E9 (fig-forth-auto680):02466 ONE FDB DOCON
+1847 0001 (fig-forth-auto680):02467 ONEV FDB 1
+ (fig-forth-auto680):02468 *
+ (fig-forth-auto680):02469 * ======>> 54 <<
+ (fig-forth-auto680):02470 * ( --- 2 )
+1849 81 (fig-forth-auto680):02471 FCB $81
+184A B2 (fig-forth-auto680):02472 FCB $B2 2
+184B 1841 (fig-forth-auto680):02473 FDB ONE-4
+184D 17E9 (fig-forth-auto680):02474 TWO FDB DOCON
+184F 0002 (fig-forth-auto680):02475 TWOV FDB 2
+ (fig-forth-auto680):02476 *
+ (fig-forth-auto680):02477 * ======>> 55 <<
+ (fig-forth-auto680):02478 * ( --- 3 )
+1851 81 (fig-forth-auto680):02479 FCB $81
+1852 B3 (fig-forth-auto680):02480 FCB $B3 3
+1853 1849 (fig-forth-auto680):02481 FDB TWO-4
+1855 17E9 (fig-forth-auto680):02482 THREE FDB DOCON
+1857 0003 (fig-forth-auto680):02483 FDB 3
+ (fig-forth-auto680):02484 *
+ (fig-forth-auto680):02485 * ======>> 56 <<
+ (fig-forth-auto680):02486 * ( --- SP )
+ (fig-forth-auto680):02487 * ASCII SPACE character
+1859 82 (fig-forth-auto680):02488 FCB $82
+185A 42 (fig-forth-auto680):02489 FCC 'B' ; 'BL'
+185B CC (fig-forth-auto680):02490 FCB $CC
+185C 1851 (fig-forth-auto680):02491 FDB THREE-4
+185E 17E9 (fig-forth-auto680):02492 BL FDB DOCON ascii blank
+1860 0020 (fig-forth-auto680):02493 FDB $20
+ (fig-forth-auto680):02494 *
+ (fig-forth-auto680):02495 * ======>> 57 <<
+ (fig-forth-auto680):02496 * This really shouldn't be a CONSTANT.
+ (fig-forth-auto680):02497 * ( --- adr )
+ (fig-forth-auto680):02498 * The base of the disk buffer space.
+1862 85 (fig-forth-auto680):02499 FCB $85
+1863 46495253 (fig-forth-auto680):02500 FCC 'FIRS' ; 'FIRST'
+1867 D4 (fig-forth-auto680):02501 FCB $D4
+1868 1859 (fig-forth-auto680):02502 FDB BL-5
+186A 17E9 (fig-forth-auto680):02503 FIRST FDB DOCON
+186C 6BE0 (fig-forth-auto680):02504 FDB BUFBAS
+ (fig-forth-auto680):02505 * FDB MEMEND-528 (132 * NBLK)
+ (fig-forth-auto680):02506 *
+ (fig-forth-auto680):02507 * ======>> 58 <<
+ (fig-forth-auto680):02508 * This really shouldn't be a CONSTANT.
+ (fig-forth-auto680):02509 * ( --- adr )
+ (fig-forth-auto680):02510 * The limit of the disk buffer space.
+186E 85 (fig-forth-auto680):02511 FCB $85
+186F 4C494D49 (fig-forth-auto680):02512 FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
+1873 D4 (fig-forth-auto680):02513 FCB $D4
+1874 1862 (fig-forth-auto680):02514 FDB FIRST-8
+1876 17E9 (fig-forth-auto680):02515 LIMIT FDB DOCON
+1878 7000 (fig-forth-auto680):02516 FDB BUFBAS+BUFSZ
+ (fig-forth-auto680):02517 * In 6800 model, was
+ (fig-forth-auto680):02518 * FDB MEMEND
+ (fig-forth-auto680):02519 *
+ (fig-forth-auto680):02520 * ======>> 59 <<
+ (fig-forth-auto680):02521 * ( --- sectorsize )
+ (fig-forth-auto680):02522 * The size, in bytes, of a buffer.
+187A 85 (fig-forth-auto680):02523 FCB $85
+187B 422F4255 (fig-forth-auto680):02524 FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
+187F C6 (fig-forth-auto680):02525 FCB $C6
+1880 186E (fig-forth-auto680):02526 FDB LIMIT-8
+1882 17E9 (fig-forth-auto680):02527 BBUF FDB DOCON
+1884 0100 (fig-forth-auto680):02528 FDB SECTSZ
+ (fig-forth-auto680):02529 * Hardcoded in 6800 model:
+ (fig-forth-auto680):02530 * FDB 128
+ (fig-forth-auto680):02531 *
+ (fig-forth-auto680):02532 * ======>> 60 <<
+ (fig-forth-auto680):02533 * ( --- blocksperscreen )
+ (fig-forth-auto680):02534 * The size, in blocks, of a screen.
+ (fig-forth-auto680):02535 * Should this be the same as NBLK, the number of block buffers maintained?
+1886 85 (fig-forth-auto680):02536 FCB $85
+1887 422F5343 (fig-forth-auto680):02537 FCC 'B/SC' ; 'B/SCR' : (blocks/screen)
+188B D2 (fig-forth-auto680):02538 FCB $D2
+188C 187A (fig-forth-auto680):02539 FDB BBUF-8
+188E 17E9 (fig-forth-auto680):02540 BSCR FDB DOCON
+1890 0004 (fig-forth-auto680):02541 FDB SCRSZ/SECTSZ
+ (fig-forth-auto680):02542 * Hardcoded in 6800 model as:
+ (fig-forth-auto680):02543 * FDB 8
+ (fig-forth-auto680):02544 * blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
+ (fig-forth-auto680):02545 *
+ (fig-forth-auto680):02546 * ======>> 61 <<
+ (fig-forth-auto680):02547 * ( n --- adr )
+ (fig-forth-auto680):02548 * Calculate the address of entry (#n/2) in the boot-up parameter table.
+ (fig-forth-auto680):02549 * (Adds the base of the boot-up table to n.)
+1892 87 (fig-forth-auto680):02550 FCB $87
+1893 2B4F52494749 (fig-forth-auto680):02551 FCC '+ORIGI' ; '+ORIGIN'
+1899 CE (fig-forth-auto680):02552 FCB $CE
+189A 1886 (fig-forth-auto680):02553 FDB BSCR-8
+189C 17B91399120016C6 (fig-forth-auto680):02554 PORIG FDB DOCOL,LIT,ORIG,PLUS
+18A4 1667 (fig-forth-auto680):02555 FDB SEMIS
+ (fig-forth-auto680):02556 *
+ (fig-forth-auto680):02557 * ######>> screen 36 <<
+ (fig-forth-auto680):02558 * ======>> 62 <<
+ (fig-forth-auto680):02559 * ( n --- adr )
+ (fig-forth-auto680):02560 * This is the per-task variable recording the initial parameter stack pointer.
+18A6 82 (fig-forth-auto680):02561 FCB $82
+18A7 53 (fig-forth-auto680):02562 FCC 'S' ; 'S0'
+18A8 B0 (fig-forth-auto680):02563 FCB $B0
+18A9 1892 (fig-forth-auto680):02564 FDB PORIG-10
+18AB 182F (fig-forth-auto680):02565 SZERO FDB DOUSER
+18AD 001E (fig-forth-auto680):02566 FDB XSPZER-UORIG
+ (fig-forth-auto680):02567 *
+ (fig-forth-auto680):02568 * ======>> 63 <<
+ (fig-forth-auto680):02569 * ( n --- adr )
+ (fig-forth-auto680):02570 * This is the per-task variable recording the initial return stack pointer.
+18AF 82 (fig-forth-auto680):02571 FCB $82
+18B0 52 (fig-forth-auto680):02572 FCC 'R' ; 'R0'
+18B1 B0 (fig-forth-auto680):02573 FCB $B0
+18B2 18A6 (fig-forth-auto680):02574 FDB SZERO-5
+18B4 182F (fig-forth-auto680):02575 RZERO FDB DOUSER
+18B6 0020 (fig-forth-auto680):02576 FDB XRZERO-UORIG
+ (fig-forth-auto680):02577 *
+ (fig-forth-auto680):02578 * ======>> 64 <<
+ (fig-forth-auto680):02579 * ( --- vadr )
+ (fig-forth-auto680):02580 * Terminal Input Buffer address.
+ (fig-forth-auto680):02581 * Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
+18B8 83 (fig-forth-auto680):02582 FCB $83
+18B9 5449 (fig-forth-auto680):02583 FCC 'TI' ; 'TIB'
+18BB C2 (fig-forth-auto680):02584 FCB $C2
+18BC 18AF (fig-forth-auto680):02585 FDB RZERO-5
+18BE 182F (fig-forth-auto680):02586 TIB FDB DOUSER
+18C0 0022 (fig-forth-auto680):02587 FDB XTIB-UORIG
+ (fig-forth-auto680):02588 *
+ (fig-forth-auto680):02589 * ======>> 65 <<
+ (fig-forth-auto680):02590 * ( --- maxnamewidth )
+ (fig-forth-auto680):02591 * This is the maximum width to which symbol names will be recorded.
+18C2 85 (fig-forth-auto680):02592 FCB $85
+18C3 57494454 (fig-forth-auto680):02593 FCC 'WIDT' ; 'WIDTH'
+18C7 C8 (fig-forth-auto680):02594 FCB $C8
+18C8 18B8 (fig-forth-auto680):02595 FDB TIB-6
+18CA 182F (fig-forth-auto680):02596 WIDTH FDB DOUSER
+18CC 0024 (fig-forth-auto680):02597 FDB XWIDTH-UORIG
+ (fig-forth-auto680):02598 *
+ (fig-forth-auto680):02599 * ======>> 66 <<
+ (fig-forth-auto680):02600 * ( --- vadr )
+ (fig-forth-auto680):02601 * Availability of error messages on disk.
+ (fig-forth-auto680):02602 * Contains 1 if messages available,
+ (fig-forth-auto680):02603 * 0 if not,
+ (fig-forth-auto680):02604 * -1 if a disk error has occurred.
+18CE 87 (fig-forth-auto680):02605 FCB $87
+18CF 5741524E494E (fig-forth-auto680):02606 FCC 'WARNIN' ; 'WARNING'
+18D5 C7 (fig-forth-auto680):02607 FCB $C7
+18D6 18C2 (fig-forth-auto680):02608 FDB WIDTH-8
+18D8 182F (fig-forth-auto680):02609 WARN FDB DOUSER
+18DA 0026 (fig-forth-auto680):02610 FDB XWARN-UORIG
+ (fig-forth-auto680):02611 *
+ (fig-forth-auto680):02612 * ======>> 67 <<
+ (fig-forth-auto680):02613 * ( --- vadr )
+ (fig-forth-auto680):02614 * Boundary for FORGET.
+18DC 85 (fig-forth-auto680):02615 FCB $85
+18DD 46454E43 (fig-forth-auto680):02616 FCC 'FENC' ; 'FENCE'
+18E1 C5 (fig-forth-auto680):02617 FCB $C5
+18E2 18CE (fig-forth-auto680):02618 FDB WARN-10
+18E4 182F (fig-forth-auto680):02619 FENCE FDB DOUSER
+18E6 0028 (fig-forth-auto680):02620 FDB XFENCE-UORIG
+ (fig-forth-auto680):02621 *
+ (fig-forth-auto680):02622 * ======>> 68 <<
+ (fig-forth-auto680):02623 * ( --- vadr )
+ (fig-forth-auto680):02624 * Dictionary pointer, fetched by HERE.
+18E8 82 (fig-forth-auto680):02625 FCB $82
+18E9 44 (fig-forth-auto680):02626 FCC 'D' ; 'DP' : points to first free byte at end of dictionary
+18EA D0 (fig-forth-auto680):02627 FCB $D0
+18EB 18DC (fig-forth-auto680):02628 FDB FENCE-8
+18ED 182F (fig-forth-auto680):02629 DICTPT FDB DOUSER
+18EF 002A (fig-forth-auto680):02630 FDB XDICTP-UORIG
+ (fig-forth-auto680):02631 *
+ (fig-forth-auto680):02632 * ======>> 68.5 <<
+ (fig-forth-auto680):02633 * ( --- vadr ) ******* Need to check what this is!
+ (fig-forth-auto680):02634 * Used in maintaining vocabularies.
+ (fig-forth-auto680):02635 * I think it points to the "parent" vocabulary, but I'm not sure.
+ (fig-forth-auto680):02636 * Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
+18F1 88 (fig-forth-auto680):02637 FCB $88
+18F2 564F432D4C494E (fig-forth-auto680):02638 FCC 'VOC-LIN' ; 'VOC-LINK'
+18F9 CB (fig-forth-auto680):02639 FCB $CB
+18FA 18E8 (fig-forth-auto680):02640 FDB DICTPT-5
+18FC 182F (fig-forth-auto680):02641 VOCLIN FDB DOUSER
+18FE 002C (fig-forth-auto680):02642 FDB XVOCL-UORIG
+ (fig-forth-auto680):02643 *
+ (fig-forth-auto680):02644 * ======>> 69 <<
+ (fig-forth-auto680):02645 * ( --- vadr )
+ (fig-forth-auto680):02646 * Disk block being interpreted.
+ (fig-forth-auto680):02647 * Zero refers to terminal.
+ (fig-forth-auto680):02648 * ******** Should be made a 32 bit user variable! ********
+ (fig-forth-auto680):02649 * But the base system needs to have full 32 bit support, div and mul, etc.
+ (fig-forth-auto680):02650 * before we can do that.
+1900 83 (fig-forth-auto680):02651 FCB $83
+1901 424C (fig-forth-auto680):02652 FCC 'BL' ; 'BLK'
+1903 CB (fig-forth-auto680):02653 FCB $CB
+1904 18F1 (fig-forth-auto680):02654 FDB VOCLIN-11
+1906 182F (fig-forth-auto680):02655 BLK FDB DOUSER
+1908 002E (fig-forth-auto680):02656 FDB XBLK-UORIG
+ (fig-forth-auto680):02657 *
+ (fig-forth-auto680):02658 * ======>> 70 <<
+ (fig-forth-auto680):02659 * ( --- vadr )
+ (fig-forth-auto680):02660 * Input buffer offset/cursor.
+190A 82 (fig-forth-auto680):02661 FCB $82
+190B 49 (fig-forth-auto680):02662 FCC 'I' ; 'IN' : scan pointer for input line buffer
+190C CE (fig-forth-auto680):02663 FCB $CE
+190D 1900 (fig-forth-auto680):02664 FDB BLK-6
+190F 182F (fig-forth-auto680):02665 IN FDB DOUSER
+1911 0030 (fig-forth-auto680):02666 FDB XIN-UORIG
+ (fig-forth-auto680):02667 *
+ (fig-forth-auto680):02668 * ======>> 71 <<
+ (fig-forth-auto680):02669 * ( --- vadr )
+ (fig-forth-auto680):02670 * Output buffer offset/cursor.
+1913 83 (fig-forth-auto680):02671 FCB $83
+1914 4F55 (fig-forth-auto680):02672 FCC 'OU' ; 'OUT'
+1916 D4 (fig-forth-auto680):02673 FCB $D4
+1917 190A (fig-forth-auto680):02674 FDB IN-5
+1919 182F (fig-forth-auto680):02675 OUT FDB DOUSER
+191B 0032 (fig-forth-auto680):02676 FDB XOUT-UORIG
+ (fig-forth-auto680):02677 *
+ (fig-forth-auto680):02678 * ======>> 72 <<
+ (fig-forth-auto680):02679 * ( --- vadr )
+ (fig-forth-auto680):02680 * Screen currently being edited, once we have an editor running.
+191D 83 (fig-forth-auto680):02681 FCB $83
+191E 5343 (fig-forth-auto680):02682 FCC 'SC' ; 'SCR'
+1920 D2 (fig-forth-auto680):02683 FCB $D2
+1921 1913 (fig-forth-auto680):02684 FDB OUT-6
+1923 182F (fig-forth-auto680):02685 SCR FDB DOUSER
+1925 0034 (fig-forth-auto680):02686 FDB XSCR-UORIG
+ (fig-forth-auto680):02687 * ######>> screen 37 <<
+ (fig-forth-auto680):02688 *
+ (fig-forth-auto680):02689 * ======>> 73 <<
+ (fig-forth-auto680):02690 * ( --- vadr )
+ (fig-forth-auto680):02691 * Sector offset for LOADing screens,
+ (fig-forth-auto680):02692 * set by DRIVE to make a new drive the default.
+ (fig-forth-auto680):02693 * This should also be 32 bit or bigger.
+1927 86 (fig-forth-auto680):02694 FCB $86
+1928 4F46465345 (fig-forth-auto680):02695 FCC 'OFFSE' ; 'OFFSET'
+192D D4 (fig-forth-auto680):02696 FCB $D4
+192E 191D (fig-forth-auto680):02697 FDB SCR-6
+1930 182F (fig-forth-auto680):02698 OFSET FDB DOUSER
+1932 0036 (fig-forth-auto680):02699 FDB XOFSET-UORIG
+ (fig-forth-auto680):02700 *
+ (fig-forth-auto680):02701 * ======>> 74 <<
+ (fig-forth-auto680):02702 * ( --- vadr )
+ (fig-forth-auto680):02703 * Current context of interpretation (vocabulary root).
+1934 87 (fig-forth-auto680):02704 FCB $87
+1935 434F4E544558 (fig-forth-auto680):02705 FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
+193B D4 (fig-forth-auto680):02706 FCB $D4
+193C 1927 (fig-forth-auto680):02707 FDB OFSET-9
+193E 182F (fig-forth-auto680):02708 CONTXT FDB DOUSER
+1940 0038 (fig-forth-auto680):02709 FDB XCONT-UORIG
+ (fig-forth-auto680):02710 *
+ (fig-forth-auto680):02711 * ======>> 75 <<
+ (fig-forth-auto680):02712 * ( --- vadr )
+ (fig-forth-auto680):02713 * Current context of definition (vocabulary root).
+1942 87 (fig-forth-auto680):02714 FCB $87
+1943 43555252454E (fig-forth-auto680):02715 FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
+1949 D4 (fig-forth-auto680):02716 FCB $D4
+194A 1934 (fig-forth-auto680):02717 FDB CONTXT-10
+194C 182F (fig-forth-auto680):02718 CURENT FDB DOUSER
+194E 003A (fig-forth-auto680):02719 FDB XCURR-UORIG
+ (fig-forth-auto680):02720 *
+ (fig-forth-auto680):02721 * ======>> 76 <<
+ (fig-forth-auto680):02722 * ( --- vadr )
+ (fig-forth-auto680):02723 * Compiler/interpreter state.
+1950 85 (fig-forth-auto680):02724 FCB $85
+1951 53544154 (fig-forth-auto680):02725 FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
+1955 C5 (fig-forth-auto680):02726 FCB $C5
+1956 1942 (fig-forth-auto680):02727 FDB CURENT-10
+1958 182F (fig-forth-auto680):02728 STATE FDB DOUSER
+195A 003C (fig-forth-auto680):02729 FDB XSTATE-UORIG
+ (fig-forth-auto680):02730 *
+ (fig-forth-auto680):02731 * ======>> 77 <<
+ (fig-forth-auto680):02732 * ( --- vadr )
+ (fig-forth-auto680):02733 * Numeric conversion base.
+195C 84 (fig-forth-auto680):02734 FCB $84
+195D 424153 (fig-forth-auto680):02735 FCC 'BAS' ; 'BASE' : number base for all input & output
+1960 C5 (fig-forth-auto680):02736 FCB $C5
+1961 1950 (fig-forth-auto680):02737 FDB STATE-8
+1963 182F (fig-forth-auto680):02738 BASE FDB DOUSER
+1965 003E (fig-forth-auto680):02739 FDB XBASE-UORIG
+ (fig-forth-auto680):02740 *
+ (fig-forth-auto680):02741 * ======>> 78 <<
+ (fig-forth-auto680):02742 * ( --- vadr )
+ (fig-forth-auto680):02743 * Decimal point location for output.
+1967 83 (fig-forth-auto680):02744 FCB $83
+1968 4450 (fig-forth-auto680):02745 FCC 'DP' ; 'DPL'
+196A CC (fig-forth-auto680):02746 FCB $CC
+196B 195C (fig-forth-auto680):02747 FDB BASE-7
+196D 182F (fig-forth-auto680):02748 DPL FDB DOUSER
+196F 0040 (fig-forth-auto680):02749 FDB XDPL-UORIG
+ (fig-forth-auto680):02750 *
+ (fig-forth-auto680):02751 * ======>> 79 <<
+ (fig-forth-auto680):02752 * ( --- vadr )
+ (fig-forth-auto680):02753 * Field width for I/O formatting.
+1971 83 (fig-forth-auto680):02754 FCB $83
+1972 464C (fig-forth-auto680):02755 FCC 'FL' ; 'FLD'
+1974 C4 (fig-forth-auto680):02756 FCB $C4
+1975 1967 (fig-forth-auto680):02757 FDB DPL-6
+1977 182F (fig-forth-auto680):02758 FLD FDB DOUSER
+1979 0042 (fig-forth-auto680):02759 FDB XFLD-UORIG
+ (fig-forth-auto680):02760 *
+ (fig-forth-auto680):02761 * ======>> 80 <<
+ (fig-forth-auto680):02762 * ( --- vadr )
+ (fig-forth-auto680):02763 * Compiler stack mark for stack check.
+197B 83 (fig-forth-auto680):02764 FCB $83
+197C 4353 (fig-forth-auto680):02765 FCC 'CS' ; 'CSP'
+197E D0 (fig-forth-auto680):02766 FCB $D0
+197F 1971 (fig-forth-auto680):02767 FDB FLD-6
+1981 182F (fig-forth-auto680):02768 CSP FDB DOUSER
+1983 0044 (fig-forth-auto680):02769 FDB XCSP-UORIG
+ (fig-forth-auto680):02770 *
+ (fig-forth-auto680):02771 * ======>> 81 <<
+ (fig-forth-auto680):02772 * ( --- vadr )
+ (fig-forth-auto680):02773 * Editing cursor location.
+1985 82 (fig-forth-auto680):02774 FCB $82
+1986 52 (fig-forth-auto680):02775 FCC 'R' ; 'R#'
+1987 A3 (fig-forth-auto680):02776 FCB $A3
+1988 197B (fig-forth-auto680):02777 FDB CSP-6
+198A 182F (fig-forth-auto680):02778 RNUM FDB DOUSER
+198C 0046 (fig-forth-auto680):02779 FDB XRNUM-UORIG
+ (fig-forth-auto680):02780 *
+ (fig-forth-auto680):02781 * ======>> 82 <<
+ (fig-forth-auto680):02782 * ( --- vadr )
+ (fig-forth-auto680):02783 * Pointer to last HELD character in PAD.
+198E 83 (fig-forth-auto680):02784 FCB $83
+198F 484C (fig-forth-auto680):02785 FCC 'HL' ; 'HLD'
+1991 C4 (fig-forth-auto680):02786 FCB $C4
+1992 1985 (fig-forth-auto680):02787 FDB RNUM-5
+1994 17E9 (fig-forth-auto680):02788 HLD FDB DOCON
+1996 7C48 (fig-forth-auto680):02789 FDB XHLD
+ (fig-forth-auto680):02790 *
+ (fig-forth-auto680):02791 * ======>> 82.5 <<== SPECIAL
+ (fig-forth-auto680):02792 * ( --- vadr )
+ (fig-forth-auto680):02793 * Line width of active terminal.
+1998 87 (fig-forth-auto680):02794 FCB $87
+1999 434F4C554D4E (fig-forth-auto680):02795 FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
+199F D3 (fig-forth-auto680):02796 FCB $D3
+19A0 198E (fig-forth-auto680):02797 FDB HLD-6
+19A2 182F (fig-forth-auto680):02798 COLUMS FDB DOUSER
+19A4 004C (fig-forth-auto680):02799 FDB XCOLUM-UORIG
+ (fig-forth-auto680):02800 *
+ (fig-forth-auto680):02801 * ######>> screen 38 <<
+ (fig-forth-auto680):02802 **
+ (fig-forth-auto680):02803 ** An INCREMENTER probably should not be defined without a defined CONSTANT?
+ (fig-forth-auto680):02804 **
+ (fig-forth-auto680):02805 ** Make an INCREMENTER compiling word (not in model):
+ (fig-forth-auto680):02806 ** ( n --- )
+ (fig-forth-auto680):02807 ** { n INCREMENTER name } typical input
+ (fig-forth-auto680):02808 ** CREATE a header and compile the increment constant,
+ (fig-forth-auto680):02809 ** then overwrite the header with a call to DOINC.
+ (fig-forth-auto680):02810 * FCB $8B
+ (fig-forth-auto680):02811 * FCC 'INCREMENTE' ; 'INCREMENTER'
+ (fig-forth-auto680):02812 * FCB $D2
+ (fig-forth-auto680):02813 * FDB COLUMS-10
+ (fig-forth-auto680):02814 * INCR FDB DOCOL,CON,PSCODE
+ (fig-forth-auto680):02815 ** ( n --- ninc )
+ (fig-forth-auto680):02816 ** Characteristic of an INCREMENTER.
+ (fig-forth-auto680):02817 ** This is too naive:
+ (fig-forth-auto680):02818 * DOINC LDD ,U
+ (fig-forth-auto680):02819 * ADDD NATWID,X ; Add the increment.
+ (fig-forth-auto680):02820 * STD ,U
+ (fig-forth-auto680):02821 * RTS
+ (fig-forth-auto680):02822 * Compiling word should check that it is compiling a CONSTANT.
+ (fig-forth-auto680):02823 *
+ (fig-forth-auto680):02824 * ======>> 83 <<
+ (fig-forth-auto680):02825 * ( n --- n+1 )
+19A6 82 (fig-forth-auto680):02826 FCB $82
+19A7 31 (fig-forth-auto680):02827 FCC '1' ; '1+'
+19A8 AB (fig-forth-auto680):02828 FCB $AB
+19A9 1998 (fig-forth-auto680):02829 FDB COLUMS-10
+ (fig-forth-auto680):02830 * Using the model keeps things semantically connected for other processors:
+19AB 17B9184516C6 (fig-forth-auto680):02831 ONEP FDB DOCOL,ONE,PLUS
+19B1 1667 (fig-forth-auto680):02832 FDB SEMIS
+ (fig-forth-auto680):02833 ** Greedy alternative:
+ (fig-forth-auto680):02834 * ONEP FDB *+NATWID
+ (fig-forth-auto680):02835 * LDD ,U
+ (fig-forth-auto680):02836 * ADDD ONEV,PCR
+ (fig-forth-auto680):02837 * STD ,U
+ (fig-forth-auto680):02838 * RTS
+ (fig-forth-auto680):02839 * Naive alternative:
+ (fig-forth-auto680):02840 * ONEP FDB DOINC
+ (fig-forth-auto680):02841 * FDB 1
+ (fig-forth-auto680):02842 * Naive alternative:
+ (fig-forth-auto680):02843 * ONEP FDB *+NATWID
+ (fig-forth-auto680):02844 * LDD ,U
+ (fig-forth-auto680):02845 * ADDD #1 ; It's hard to imagine 1+ being other than 1.
+ (fig-forth-auto680):02846 * STD ,U
+ (fig-forth-auto680):02847 * RTS
+ (fig-forth-auto680):02848 *
+ (fig-forth-auto680):02849 * ======>> 84 <<
+ (fig-forth-auto680):02850 * ( n --- n+2 )
+19B3 82 (fig-forth-auto680):02851 FCB $82
+19B4 32 (fig-forth-auto680):02852 FCC '2' ; '2+'
+19B5 AB (fig-forth-auto680):02853 FCB $AB
+19B6 19A6 (fig-forth-auto680):02854 FDB ONEP-5
+ (fig-forth-auto680):02855 * Using the model keeps things semantically connected for other processors:
+19B8 17B9184D16C6 (fig-forth-auto680):02856 TWOP FDB DOCOL,TWO,PLUS
+19BE 1667 (fig-forth-auto680):02857 FDB SEMIS
+ (fig-forth-auto680):02858 ** Greedy alternative:
+ (fig-forth-auto680):02859 * TWOP FDB *+NATWID
+ (fig-forth-auto680):02860 * LDD ,U
+ (fig-forth-auto680):02861 * ADDD TWOV,PCR ; See NAT+ (NATP)
+ (fig-forth-auto680):02862 * STD ,U
+ (fig-forth-auto680):02863 * RTS
+ (fig-forth-auto680):02864 * Naive alternative:
+ (fig-forth-auto680):02865 * TWOP FDB DOINC
+ (fig-forth-auto680):02866 * FDB 2
+ (fig-forth-auto680):02867 * Naive alternative:
+ (fig-forth-auto680):02868 * TWOP FDB *+NATWID
+ (fig-forth-auto680):02869 * LDD ,U
+ (fig-forth-auto680):02870 * ADDD #2 ; See NAT+ (NATP)
+ (fig-forth-auto680):02871 * STD ,U
+ (fig-forth-auto680):02872 * RTS
+ (fig-forth-auto680):02873 *
+ (fig-forth-auto680):02874 * ======>> 85 <<
+ (fig-forth-auto680):02875 * ( --- adr )
+ (fig-forth-auto680):02876 * Get the DICTPT allocation, like a USER constant.
+ (fig-forth-auto680):02877 * Should check the stack and heap for collision.
+19C0 84 (fig-forth-auto680):02878 FCB $84
+19C1 484552 (fig-forth-auto680):02879 FCC 'HER' ; 'HERE'
+19C4 C5 (fig-forth-auto680):02880 FCB $C5
+19C5 19B3 (fig-forth-auto680):02881 FDB TWOP-5
+19C7 17B918ED1772 (fig-forth-auto680):02882 HERE FDB DOCOL,DICTPT,AT
+19CD 1667 (fig-forth-auto680):02883 FDB SEMIS
+ (fig-forth-auto680):02884 *
+ (fig-forth-auto680):02885 * ======>> 86 <<
+ (fig-forth-auto680):02886 * ( n --- )
+ (fig-forth-auto680):02887 * Increase/decrease heap (add n to DP),
+ (fig-forth-auto680):02888 * Should ERROR check stack/heap.
+19CF 85 (fig-forth-auto680):02889 FCB $85
+19D0 414C4C4F (fig-forth-auto680):02890 FCC 'ALLO' ; 'ALLOT'
+19D4 D4 (fig-forth-auto680):02891 FCB $D4
+19D5 19C0 (fig-forth-auto680):02892 FDB HERE-7
+19D7 17B918ED1751 (fig-forth-auto680):02893 ALLOT FDB DOCOL,DICTPT,PSTORE
+19DD 1667 (fig-forth-auto680):02894 FDB SEMIS
+ (fig-forth-auto680):02895 *
+ (fig-forth-auto680):02896 * ======>> 87 <<
+ (fig-forth-auto680):02897 * ( n --- )
+ (fig-forth-auto680):02898 * Store word n at DP++,
+ (fig-forth-auto680):02899 * Should ERROR check stack/heap.
+19DF 81 (fig-forth-auto680):02900 FCB $81 ; , (COMMA)
+19E0 AC (fig-forth-auto680):02901 FCB $AC
+19E1 19CF (fig-forth-auto680):02902 FDB ALLOT-8
+19E3 17B919C7178A17F7 (fig-forth-auto680):02903 COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT
+ 19D7
+19ED 1667 (fig-forth-auto680):02904 FDB SEMIS
+ (fig-forth-auto680):02905 * COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
+ (fig-forth-auto680):02906 * FDB SEMIS
+ (fig-forth-auto680):02907 *
+ (fig-forth-auto680):02908 * ======>> 88 <<
+ (fig-forth-auto680):02909 * ( b --- )
+ (fig-forth-auto680):02910 * Store byte b at DP+,
+ (fig-forth-auto680):02911 * Should ERROR check stack/heap.
+19EF 82 (fig-forth-auto680):02912 FCB $82
+19F0 43 (fig-forth-auto680):02913 FCC 'C' ; 'C,'
+19F1 AC (fig-forth-auto680):02914 FCB $AC
+19F2 19DF (fig-forth-auto680):02915 FDB COMMA-4
+19F4 17B919C717981845 (fig-forth-auto680):02916 CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
+ 19D7
+19FE 1667 (fig-forth-auto680):02917 FDB SEMIS
+ (fig-forth-auto680):02918 *
+ (fig-forth-auto680):02919 * ======>> 89 <<
+ (fig-forth-auto680):02920 * ( n1 n2 --- n1-n2 )
+ (fig-forth-auto680):02921 * Subtract top two words.
+1A00 81 (fig-forth-auto680):02922 FCB $81 ; -
+1A01 AD (fig-forth-auto680):02923 FCB $AD
+1A02 19EF (fig-forth-auto680):02924 FDB CCOMM-5
+1A04 1A06 (fig-forth-auto680):02925 SUB FDB *+NATWID
+1A06 EC42 (fig-forth-auto680):02926 LDD NATWID,U ; #2~6
+1A08 A3C1 (fig-forth-auto680):02927 SUBD ,U++ ; #2~9
+1A0A EDC4 (fig-forth-auto680):02928 STD ,U ; #2~5
+1A0C 39 (fig-forth-auto680):02929 RTS ; #1~5 = #7~25
+ (fig-forth-auto680):02930 * SUB FDB DOCOL,MINUS,PLUS
+ (fig-forth-auto680):02931 * FDB SEMIS ; Costs 6 bytes and lots of cycles.
+ (fig-forth-auto680):02932 *
+ (fig-forth-auto680):02933 * ======>> 90 <<
+ (fig-forth-auto680):02934 * ( n1 n2 --- n1==n2 )
+ (fig-forth-auto680):02935 * Return flag true if n1 and n2 are equal, otherwise false.
+1A0D 81 (fig-forth-auto680):02936 FCB $81 =
+1A0E BD (fig-forth-auto680):02937 FCB $BD
+1A0F 1A00 (fig-forth-auto680):02938 FDB SUB-4
+1A11 17B91A0416A3 (fig-forth-auto680):02939 EQUAL FDB DOCOL,SUB,ZEQU
+1A17 1667 (fig-forth-auto680):02940 FDB SEMIS
+ (fig-forth-auto680):02941 *
+ (fig-forth-auto680):02942 * ======>> 91 <<
+ (fig-forth-auto680):02943 * ( n1 n2 --- n1<n2 )
+ (fig-forth-auto680):02944 * Return flag true if n1 is less than n2, otherwise false.
+1A19 81 (fig-forth-auto680):02945 FCB $81 <
+1A1A BC (fig-forth-auto680):02946 FCB $BC
+1A1B 1A0D (fig-forth-auto680):02947 FDB EQUAL-4
+1A1D 1A1F (fig-forth-auto680):02948 LESS FDB *+NATWID
+1A1F EC42 (fig-forth-auto680):02949 LDD NATWID,U
+1A21 A3C1 (fig-forth-auto680):02950 SUBD ,U++
+1A23 2C06 (fig-forth-auto680):02951 BGE FALSE
+1A25 CC0001 (fig-forth-auto680):02952 TRUE LDD #1
+1A28 EDC4 (fig-forth-auto680):02953 STD ,U
+1A2A 39 (fig-forth-auto680):02954 RTS
+1A2B CC0000 (fig-forth-auto680):02955 FALSE LDD #0
+1A2E EDC4 (fig-forth-auto680):02956 STD ,U
+1A30 39 (fig-forth-auto680):02957 RTS
+ (fig-forth-auto680):02958 * PULS A ;
+ (fig-forth-auto680):02959 * PULS B ;
+ (fig-forth-auto680):02960 * TFR S,X ; TSX :
+ (fig-forth-auto680):02961 * CMPA 0,X
+ (fig-forth-auto680):02962 * LEAS 1,S ;
+ (fig-forth-auto680):02963 * BGT LESST
+ (fig-forth-auto680):02964 * BNE LESSF
+ (fig-forth-auto680):02965 * CMPB 1,X ; Why not sub, sbc, bge?
+ (fig-forth-auto680):02966 * BHI LESST
+ (fig-forth-auto680):02967 * LESSF CLRB ;
+ (fig-forth-auto680):02968 * BRA LESSX
+ (fig-forth-auto680):02969 * LESST LDB #1
+ (fig-forth-auto680):02970 * LESSX CLRA ;
+ (fig-forth-auto680):02971 * LEAS 1,S ;
+ (fig-forth-auto680):02972 * JMP PUSHBA
+ (fig-forth-auto680):02973 *
+ (fig-forth-auto680):02974 * ======>> 92 <<
+ (fig-forth-auto680):02975 * ( n1 n2 --- n1>n2 )
+ (fig-forth-auto680):02976 * Return flag true if n1 is greater than n2, false otherwise.
+1A31 81 (fig-forth-auto680):02977 FCB $81 >
+1A32 BE (fig-forth-auto680):02978 FCB $BE
+1A33 1A19 (fig-forth-auto680):02979 FDB LESS-4
+1A35 17B917361A1D (fig-forth-auto680):02980 GREAT FDB DOCOL,SWAP,LESS
+1A3B 1667 (fig-forth-auto680):02981 FDB SEMIS
+ (fig-forth-auto680):02982 *
+ (fig-forth-auto680):02983 * ======>> 93 <<
+ (fig-forth-auto680):02984 * ( n1 n2 n3 --- n2 n3 n1 )
+ (fig-forth-auto680):02985 * Rotate the top three words on stack,
+ (fig-forth-auto680):02986 * bringing the third word to the top.
+1A3D 83 (fig-forth-auto680):02987 FCB $83
+1A3E 524F (fig-forth-auto680):02988 FCC 'RO' ; 'ROT'
+1A40 D4 (fig-forth-auto680):02989 FCB $D4
+1A41 1A31 (fig-forth-auto680):02990 FDB GREAT-4
+1A43 1A45 (fig-forth-auto680):02991 ROT FDB *+NATWID
+1A45 3420 (fig-forth-auto680):02992 PSHS Y
+1A47 3736 (fig-forth-auto680):02993 PULU D,X,Y
+1A49 3616 (fig-forth-auto680):02994 PSHU D,X
+1A4B 3620 (fig-forth-auto680):02995 PSHU Y
+1A4D 35A0 (fig-forth-auto680):02996 PULS Y,PC
+ (fig-forth-auto680):02997 * ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
+ (fig-forth-auto680):02998 * FDB SEMIS
+ (fig-forth-auto680):02999 *
+ (fig-forth-auto680):03000 * ======>> 94 <<
+ (fig-forth-auto680):03001 * ( --- )
+ (fig-forth-auto680):03002 * EMIT a SPACE.
+1A4F 85 (fig-forth-auto680):03003 FCB $85
+1A50 53504143 (fig-forth-auto680):03004 FCC 'SPAC' ; 'SPACE'
+1A54 C5 (fig-forth-auto680):03005 FCB $C5
+1A55 1A3D (fig-forth-auto680):03006 FDB ROT-6
+1A57 17B9185E1542 (fig-forth-auto680):03007 SPACE FDB DOCOL,BL,EMIT
+1A5D 1667 (fig-forth-auto680):03008 FDB SEMIS
+ (fig-forth-auto680):03009 *
+ (fig-forth-auto680):03010 * ======>> 95 <<
+ (fig-forth-auto680):03011 * ( n0 n1 --- min(n0,n1) )
+ (fig-forth-auto680):03012 * Leave the minimum of the top two integers.
+ (fig-forth-auto680):03013 * Being too greedy here, but, whatever.
+1A5F 83 (fig-forth-auto680):03014 FCB $83
+1A60 4D49 (fig-forth-auto680):03015 FCC 'MI' ; 'MIN'
+1A62 CE (fig-forth-auto680):03016 FCB $CE
+1A63 1A4F (fig-forth-auto680):03017 FDB SPACE-8
+1A65 1A67 (fig-forth-auto680):03018 MIN FDB *+NATWID
+1A67 3706 (fig-forth-auto680):03019 PULU D
+1A69 10A3C4 (fig-forth-auto680):03020 CMPD ,U
+1A6C 2F02 (fig-forth-auto680):03021 BLE MINX
+1A6E EDC4 (fig-forth-auto680):03022 STD ,U
+1A70 39 (fig-forth-auto680):03023 MINX RTS
+ (fig-forth-auto680):03024 * MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
+ (fig-forth-auto680):03025 * FDB MIN2-*-NATWID
+ (fig-forth-auto680):03026 * FDB SWAP
+ (fig-forth-auto680):03027 * MIN2 FDB DROP
+ (fig-forth-auto680):03028 * FDB SEMIS
+ (fig-forth-auto680):03029 *
+ (fig-forth-auto680):03030 * ======>> 96 <<
+ (fig-forth-auto680):03031 * ( n0 n1 --- max(n0,n1) )
+ (fig-forth-auto680):03032 * Leave the maximum of the top two integers.
+ (fig-forth-auto680):03033 * Really should leave this as in the model.
+1A71 83 (fig-forth-auto680):03034 FCB $83
+1A72 4D41 (fig-forth-auto680):03035 FCC 'MA' ; 'MAX'
+1A74 D8 (fig-forth-auto680):03036 FCB $D8
+1A75 1A5F (fig-forth-auto680):03037 FDB MIN-6
+1A77 1A79 (fig-forth-auto680):03038 MAX FDB *+NATWID
+1A79 3706 (fig-forth-auto680):03039 PULU D
+1A7B 10A3C4 (fig-forth-auto680):03040 CMPD ,U
+1A7E 2F02 (fig-forth-auto680):03041 BLE MAXX
+1A80 EDC4 (fig-forth-auto680):03042 STD ,U
+1A82 39 (fig-forth-auto680):03043 MAXX RTS
+ (fig-forth-auto680):03044 * MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
+ (fig-forth-auto680):03045 * FDB MAX2-*-NATWID
+ (fig-forth-auto680):03046 * FDB SWAP
+ (fig-forth-auto680):03047 * MAX2 FDB DROP
+ (fig-forth-auto680):03048 * FDB SEMIS
+ (fig-forth-auto680):03049 *
+ (fig-forth-auto680):03050 * ======>> 97 <<
+ (fig-forth-auto680):03051 * ( 0 --- 0 )
+ (fig-forth-auto680):03052 * ( n --- n n )
+ (fig-forth-auto680):03053 * DUP if non-zero.
+1A83 84 (fig-forth-auto680):03054 FCB $84
+1A84 2D4455 (fig-forth-auto680):03055 FCC '-DU' ; '-DUP'
+1A87 D0 (fig-forth-auto680):03056 FCB $D0
+1A88 1A71 (fig-forth-auto680):03057 FDB MAX-6
+1A8A 1A8C (fig-forth-auto680):03058 DDUP FDB *+NATWID
+1A8C ECC4 (fig-forth-auto680):03059 LDD ,U
+1A8E 2702 (fig-forth-auto680):03060 BEQ DDUPX
+1A90 3606 (fig-forth-auto680):03061 PSHU D
+1A92 39 (fig-forth-auto680):03062 DDUPX RTS
+ (fig-forth-auto680):03063 * DDUP FDB DOCOL,DUP,ZBRAN
+ (fig-forth-auto680):03064 * FDB DDUP2-*-NATWID
+ (fig-forth-auto680):03065 * FDB DUP
+ (fig-forth-auto680):03066 * DDUP2 FDB SEMIS
+ (fig-forth-auto680):03067 *
+ (fig-forth-auto680):03068 * ######>> screen 39 <<
+ (fig-forth-auto680):03069 * ======>> 98.1 <<
+ (fig-forth-auto680):03070 * Supplemental:
+ (fig-forth-auto680):03071 * ( n<0 --- -1 )
+ (fig-forth-auto680):03072 * ( n>=~ --- 1 )
+ (fig-forth-auto680):03073 * Change top integer to its sign.
+1A93 86 (fig-forth-auto680):03074 FCB $86
+1A94 5349474E55 (fig-forth-auto680):03075 FCC 'SIGNU' ; 'SIGNUM'
+1A99 CD (fig-forth-auto680):03076 FCB $CD
+1A9A 1A83 (fig-forth-auto680):03077 FDB DDUP-7
+1A9C 1A9E (fig-forth-auto680):03078 SIGNUM FDB *+NATWID
+1A9E C601 (fig-forth-auto680):03079 SIGNUE LDB #1
+1AA0 A6C4 (fig-forth-auto680):03080 LDA ,U
+1AA2 2A01 (fig-forth-auto680):03081 BPL SIGNUP
+1AA4 50 (fig-forth-auto680):03082 NEGB
+1AA5 1D (fig-forth-auto680):03083 SIGNUP SEX ; Couldn't they have called SignEXtend EXT instead?
+1AA6 EDC4 (fig-forth-auto680):03084 STD ,U ; Am I too much of a prude?
+1AA8 39 (fig-forth-auto680):03085 RTS
+ (fig-forth-auto680):03086 * 6800 model version should be something like this:
+ (fig-forth-auto680):03087 * LDB #1
+ (fig-forth-auto680):03088 * CLRA
+ (fig-forth-auto680):03089 * TSX
+ (fig-forth-auto680):03090 * TST ,X
+ (fig-forth-auto680):03091 * BPL SIGNUP
+ (fig-forth-auto680):03092 * NEGB
+ (fig-forth-auto680):03093 * COMA
+ (fig-forth-auto680):03094 * SIGNUP JMP STABX
+ (fig-forth-auto680):03095 *
+ (fig-forth-auto680):03096 * ======>> 98 <<
+ (fig-forth-auto680):03097 * ( adr1 direction --- adr2 )
+ (fig-forth-auto680):03098 * TRAVERSE the symbol name.
+ (fig-forth-auto680):03099 * If direction is 1, find the end.
+ (fig-forth-auto680):03100 * If direction is -1, find the beginning.
+1AA9 88 (fig-forth-auto680):03101 FCB $88
+1AAA 54524156455253 (fig-forth-auto680):03102 FCC 'TRAVERS' ; 'TRAVERSE'
+1AB1 C5 (fig-forth-auto680):03103 FCB $C5
+1AB2 1A93 (fig-forth-auto680):03104 FDB SIGNUM-9
+1AB4 1AB6 (fig-forth-auto680):03105 TRAV FDB *+NATWID
+1AB6 8DE6 (fig-forth-auto680):03106 BSR SIGNUE ; Convert negative to -, zero or positive to 1.
+1AB8 ECC1 (fig-forth-auto680):03107 LDD ,U++ ; Still in D, but we have to pop it anyway.
+1ABA AEC4 (fig-forth-auto680):03108 LDX ,U ; If D is 1 or -1, so is B.
+1ABC 867F (fig-forth-auto680):03109 LDA #$7F
+1ABE 3085 (fig-forth-auto680):03110 TRAVLP LEAX B,X ; Don't look at the one we start at.
+1AC0 A184 (fig-forth-auto680):03111 CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL.
+1AC2 24FA (fig-forth-auto680):03112 BCC TRAVLP
+1AC4 AFC4 (fig-forth-auto680):03113 TRAVDN STX ,U
+1AC6 39 (fig-forth-auto680):03114 RTS
+ (fig-forth-auto680):03115 * Doing this in 6809 just because it can be done may be getting too greedy.
+ (fig-forth-auto680):03116 * TRAV FDB DOCOL,SWAP
+ (fig-forth-auto680):03117 * TRAV2 FDB OVER,PLUS,LIT8
+ (fig-forth-auto680):03118 * FCB $7F
+ (fig-forth-auto680):03119 * FDB OVER,CAT,LESS,ZBRAN
+ (fig-forth-auto680):03120 * FDB TRAV2-*-NATWID
+ (fig-forth-auto680):03121 * FDB SWAP,DROP
+ (fig-forth-auto680):03122 * FDB SEMIS
+ (fig-forth-auto680):03123 *
+ (fig-forth-auto680):03124 * ======>> 99 <<
+ (fig-forth-auto680):03125 * ( --- symptr )
+ (fig-forth-auto680):03126 * Fetch CURRENT as a per-USER constant.
+1AC7 86 (fig-forth-auto680):03127 FCB $86
+1AC8 4C41544553 (fig-forth-auto680):03128 FCC 'LATES' ; 'LATEST'
+1ACD D4 (fig-forth-auto680):03129 FCB $D4
+1ACE 1AA9 (fig-forth-auto680):03130 FDB TRAV-11
+1AD0 17B9194C17721772 (fig-forth-auto680):03131 LATEST FDB DOCOL,CURENT,AT,AT
+1AD8 1667 (fig-forth-auto680):03132 FDB SEMIS
+ (fig-forth-auto680):03133 * LATEST FDB *+NATWID
+ (fig-forth-auto680):03134 * Getting too greedy:
+ (fig-forth-auto680):03135 * Version 1:
+ (fig-forth-auto680):03136 * TFR DP,A
+ (fig-forth-auto680):03137 * CLRB
+ (fig-forth-auto680):03138 * TFR D,X
+ (fig-forth-auto680):03139 * LDD CURENT+NATWID,PCR
+ (fig-forth-auto680):03140 * LDX [D,X]
+ (fig-forth-auto680):03141 * PSHU X ; Leave the address in X.
+ (fig-forth-auto680):03142 * RTS
+ (fig-forth-auto680):03143 * Version 2:
+ (fig-forth-auto680):03144 * LEAX CURENT,PCR
+ (fig-forth-auto680):03145 * JSR [,X]
+ (fig-forth-auto680):03146 * PULU X
+ (fig-forth-auto680):03147 * LDX [,X]
+ (fig-forth-auto680):03148 * PSHU X
+ (fig-forth-auto680):03149 * RTS
+ (fig-forth-auto680):03150 * Too greedy, too many smantic holes to fall through.
+ (fig-forth-auto680):03151 * If the address at the CFA is made relative,
+ (fig-forth-auto680):03152 * this is part of the code that would be affected
+ (fig-forth-auto680):03153 * if it is in native CPU code.
+ (fig-forth-auto680):03154 *
+ (fig-forth-auto680):03155 * ======>> 100 <<
+ (fig-forth-auto680):03156 * Wanted to do these as INCREMENTERs,
+ (fig-forth-auto680):03157 * but I need to stick with the model as much as possible,
+ (fig-forth-auto680):03158 * (mostly, LOL) adding code only to make the model more clear.
+ (fig-forth-auto680):03159 * ( pfa --- lfa )
+ (fig-forth-auto680):03160 * Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
+1ADA 83 (fig-forth-auto680):03161 FCB $83
+1ADB 4C46 (fig-forth-auto680):03162 FCC 'LF' ; 'LFA'
+1ADD C1 (fig-forth-auto680):03163 FCB $C1
+1ADE 1AC7 (fig-forth-auto680):03164 FDB LATEST-9
+1AE0 17B913A7 (fig-forth-auto680):03165 LFA FDB DOCOL,LIT8
+ (fig-forth-auto680):03166 * FCB 4
+1AE4 04 (fig-forth-auto680):03167 FCB 2*NATWID
+1AE5 1A04 (fig-forth-auto680):03168 FDB SUB
+1AE7 1667 (fig-forth-auto680):03169 FDB SEMIS
+ (fig-forth-auto680):03170 *
+ (fig-forth-auto680):03171 * ======>> 101 <<
+ (fig-forth-auto680):03172 * ( pfa --- cfa )
+ (fig-forth-auto680):03173 * Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
+1AE9 83 (fig-forth-auto680):03174 FCB $83
+1AEA 4346 (fig-forth-auto680):03175 FCC 'CF' ; 'CFA'
+1AEC C1 (fig-forth-auto680):03176 FCB $C1
+1AED 1ADA (fig-forth-auto680):03177 FDB LFA-6
+ (fig-forth-auto680):03178 * CFA FDB DOCOL,TWO,SUB
+1AEF 17B917F71A04 (fig-forth-auto680):03179 CFA FDB DOCOL,NATWC,SUB
+1AF5 1667 (fig-forth-auto680):03180 FDB SEMIS
+ (fig-forth-auto680):03181 *
+ (fig-forth-auto680):03182 * ======>> 102 <<
+ (fig-forth-auto680):03183 * ( pfa --- nfa )
+ (fig-forth-auto680):03184 * Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
+1AF7 83 (fig-forth-auto680):03185 FCB $83
+1AF8 4E46 (fig-forth-auto680):03186 FCC 'NF' ; 'NFA'
+1AFA C1 (fig-forth-auto680):03187 FCB $C1
+1AFB 1AE9 (fig-forth-auto680):03188 FDB CFA-6
+1AFD 17B913A7 (fig-forth-auto680):03189 NFA FDB DOCOL,LIT8
+ (fig-forth-auto680):03190 * FCB 5
+1B01 05 (fig-forth-auto680):03191 FCB NATWID*2+1
+1B02 1A04184516EF1AB4 (fig-forth-auto680):03192 FDB SUB,ONE,MINUS,TRAV
+1B0A 1667 (fig-forth-auto680):03193 FDB SEMIS
+ (fig-forth-auto680):03194 *
+ (fig-forth-auto680):03195 * ======>> 103 <<
+ (fig-forth-auto680):03196 * ( nfa --- pfa )
+ (fig-forth-auto680):03197 * Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
+1B0C 83 (fig-forth-auto680):03198 FCB $83
+1B0D 5046 (fig-forth-auto680):03199 FCC 'PF' ; 'PFA'
+1B0F C1 (fig-forth-auto680):03200 FCB $C1
+1B10 1AF7 (fig-forth-auto680):03201 FDB NFA-6
+1B12 17B918451AB413A7 (fig-forth-auto680):03202 PFA FDB DOCOL,ONE,TRAV,LIT8
+ (fig-forth-auto680):03203 * FCB 5
+1B1A 05 (fig-forth-auto680):03204 FCB NATWID*2+1
+1B1B 16C6 (fig-forth-auto680):03205 FDB PLUS
+1B1D 1667 (fig-forth-auto680):03206 FDB SEMIS
+ (fig-forth-auto680):03207 *
+ (fig-forth-auto680):03208 * ######>> screen 40 <<
+ (fig-forth-auto680):03209 * ======>> 104 <<
+ (fig-forth-auto680):03210 * ( --- )
+ (fig-forth-auto680):03211 * Save the parameter stack pointer in CSP for compiler checks.
+1B1F 84 (fig-forth-auto680):03212 FCB $84
+1B20 214353 (fig-forth-auto680):03213 FCC '!CS' ; '!CSP'
+1B23 D0 (fig-forth-auto680):03214 FCB $D0
+1B24 1B0C (fig-forth-auto680):03215 FDB PFA-6
+1B26 17B916401981178A (fig-forth-auto680):03216 SCSP FDB DOCOL,SPAT,CSP,STORE
+1B2E 1667 (fig-forth-auto680):03217 FDB SEMIS
+ (fig-forth-auto680):03218 *
+ (fig-forth-auto680):03219 * ======>> 105 <<
+ (fig-forth-auto680):03220 * ( 0 n --- ) ( *** )
+ (fig-forth-auto680):03221 * ( true n --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03222 * If flag is false, do nothing.
+ (fig-forth-auto680):03223 * If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
+ (fig-forth-auto680):03224 * Leaves cursor position (IN)
+ (fig-forth-auto680):03225 * and currently loading block number (BLK) on stack, for analysis.
+ (fig-forth-auto680):03226 *
+ (fig-forth-auto680):03227 * This one is too important to be high-level Forth codes.
+ (fig-forth-auto680):03228 * When we have an error, we want to disturb as little as possible.
+ (fig-forth-auto680):03229 * But fixing that cascades through ERROR and MESSAGE
+ (fig-forth-auto680):03230 * into the disk block system.
+ (fig-forth-auto680):03231 * And we aren't ready for that yet.
+1B30 86 (fig-forth-auto680):03232 FCB $86
+1B31 3F4552524F (fig-forth-auto680):03233 FCC '?ERRO' ; '?ERROR'
+1B36 D2 (fig-forth-auto680):03234 FCB $D2
+1B37 1B1F (fig-forth-auto680):03235 FDB SCSP-7
+ (fig-forth-auto680):03236 * QERR FDB *+NATWID
+ (fig-forth-auto680):03237 * LDD NATWID,U
+ (fig-forth-auto680):03238 * BNE QERROR
+ (fig-forth-auto680):03239 * LEAU 2*NATWID,U
+ (fig-forth-auto680):03240 * RTS
+ (fig-forth-auto680):03241 ** this doesn't work anyway: QERROR LBR ERROR
+1B39 17B917361409 (fig-forth-auto680):03242 QERR FDB DOCOL,SWAP,ZBRAN
+1B3F 0006 (fig-forth-auto680):03243 FDB QERR2-*-NATWID
+1B41 1FE713FA (fig-forth-auto680):03244 FDB ERROR,BRAN
+1B45 0002 (fig-forth-auto680):03245 FDB QERR3-*-NATWID
+1B47 172A (fig-forth-auto680):03246 QERR2 FDB DROP
+1B49 1667 (fig-forth-auto680):03247 QERR3 FDB SEMIS
+ (fig-forth-auto680):03248 *
+ (fig-forth-auto680):03249 * ======>> 106 <<
+ (fig-forth-auto680):03250 * STATE is compiling:
+ (fig-forth-auto680):03251 * ( --- ) ( *** )
+ (fig-forth-auto680):03252 * STATE is compiling:
+ (fig-forth-auto680):03253 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03254 * ERROR if not compiling.
+1B4B 85 (fig-forth-auto680):03255 FCB $85
+1B4C 3F434F4D (fig-forth-auto680):03256 FCC '?COM' ; '?COMP'
+1B50 D0 (fig-forth-auto680):03257 FCB $D0
+1B51 1B30 (fig-forth-auto680):03258 FDB QERR-9
+1B53 17B91958177216A3 (fig-forth-auto680):03259 QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8
+ 13A7
+1B5D 11 (fig-forth-auto680):03260 FCB $11
+1B5E 1B39 (fig-forth-auto680):03261 FDB QERR
+1B60 1667 (fig-forth-auto680):03262 FDB SEMIS
+ (fig-forth-auto680):03263 *
+ (fig-forth-auto680):03264 * ======>> 107 <<
+ (fig-forth-auto680):03265 * STATE is executing:
+ (fig-forth-auto680):03266 * ( --- ) ( *** )
+ (fig-forth-auto680):03267 * STATE is executing:
+ (fig-forth-auto680):03268 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03269 * ERROR if not executing.
+1B62 85 (fig-forth-auto680):03270 FCB $85
+1B63 3F455845 (fig-forth-auto680):03271 FCC '?EXE' ; '?EXEC'
+1B67 C3 (fig-forth-auto680):03272 FCB $C3
+1B68 1B4B (fig-forth-auto680):03273 FDB QCOMP-8
+1B6A 17B91958177213A7 (fig-forth-auto680):03274 QEXEC FDB DOCOL,STATE,AT,LIT8
+1B72 12 (fig-forth-auto680):03275 FCB $12
+1B73 1B39 (fig-forth-auto680):03276 FDB QERR
+1B75 1667 (fig-forth-auto680):03277 FDB SEMIS
+ (fig-forth-auto680):03278 *
+ (fig-forth-auto680):03279 * ======>> 108 <<
+ (fig-forth-auto680):03280 * ( n1 n1 --- ) ( *** )
+ (fig-forth-auto680):03281 * ( n1 n2 --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03282 * ERROR if top two are unequal.
+ (fig-forth-auto680):03283 * MESSAGE says compiled conditionals do not match.
+1B77 86 (fig-forth-auto680):03284 FCB $86
+1B78 3F50414952 (fig-forth-auto680):03285 FCC '?PAIR' ; '?PAIRS'
+1B7D D3 (fig-forth-auto680):03286 FCB $D3
+1B7E 1B62 (fig-forth-auto680):03287 FDB QEXEC-8
+1B80 17B91A0413A7 (fig-forth-auto680):03288 QPAIRS FDB DOCOL,SUB,LIT8
+1B86 13 (fig-forth-auto680):03289 FCB $13
+1B87 1B39 (fig-forth-auto680):03290 FDB QERR
+1B89 1667 (fig-forth-auto680):03291 FDB SEMIS
+ (fig-forth-auto680):03292 *
+ (fig-forth-auto680):03293 * ======>> 109 <<
+ (fig-forth-auto680):03294 * CSP and parameter stack are balanced (equal):
+ (fig-forth-auto680):03295 * ( --- ) ( *** )
+ (fig-forth-auto680):03296 * CSP and parameter stack are not balanced (unequal):
+ (fig-forth-auto680):03297 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03298 * ERROR if return/control stack is not at same level as last !CSP.
+ (fig-forth-auto680):03299 * Usually indicates that a definition has been left incomplete.
+1B8B 84 (fig-forth-auto680):03300 FCB $84
+1B8C 3F4353 (fig-forth-auto680):03301 FCC '?CS' ; '?CSP'
+1B8F D0 (fig-forth-auto680):03302 FCB $D0
+1B90 1B77 (fig-forth-auto680):03303 FDB QPAIRS-9
+1B92 17B9164019811772 (fig-forth-auto680):03304 QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8
+ 1A0413A7
+1B9E 14 (fig-forth-auto680):03305 FCB $14
+1B9F 1B39 (fig-forth-auto680):03306 FDB QERR
+1BA1 1667 (fig-forth-auto680):03307 FDB SEMIS
+ (fig-forth-auto680):03308 *
+ (fig-forth-auto680):03309 * ======>> 110 <<
+ (fig-forth-auto680):03310 * Active BLK input:
+ (fig-forth-auto680):03311 * ( --- ) ( *** )
+ (fig-forth-auto680):03312 * No active BLK input:
+ (fig-forth-auto680):03313 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03314 * ERROR if not loading, i. e., if BLK is zero.
+1BA3 88 (fig-forth-auto680):03315 FCB $88
+1BA4 3F4C4F4144494E (fig-forth-auto680):03316 FCC '?LOADIN' ; '?LOADING'
+1BAB C7 (fig-forth-auto680):03317 FCB $C7
+1BAC 1B8B (fig-forth-auto680):03318 FDB QCSP-7
+1BAE 17B91906177216A3 (fig-forth-auto680):03319 QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8
+ 13A7
+1BB8 16 (fig-forth-auto680):03320 FCB $16
+1BB9 1B39 (fig-forth-auto680):03321 FDB QERR
+1BBB 1667 (fig-forth-auto680):03322 FDB SEMIS
+ (fig-forth-auto680):03323 *
+ (fig-forth-auto680):03324 * ######>> screen 41 <<
+ (fig-forth-auto680):03325 * ======>> 111 <<
+ (fig-forth-auto680):03326 * ( --- )
+ (fig-forth-auto680):03327 * Compile an in-line literal value from the instruction stream.
+1BBD 87 (fig-forth-auto680):03328 FCB $87
+1BBE 434F4D50494C (fig-forth-auto680):03329 FCC 'COMPIL' ; 'COMPILE'
+1BC4 C5 (fig-forth-auto680):03330 FCB $C5
+1BC5 1BA3 (fig-forth-auto680):03331 FDB QLOAD-11
+ (fig-forth-auto680):03332 * COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
+ (fig-forth-auto680):03333 * COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
+1BC7 17B91B5316901745 (fig-forth-auto680):03334 COMPIL FDB DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
+ 18021681177219E3
+1BD7 1667 (fig-forth-auto680):03335 FDB SEMIS
+ (fig-forth-auto680):03336 *
+ (fig-forth-auto680):03337 * ======>> 112 <<
+ (fig-forth-auto680):03338 * ( --- ) P
+ (fig-forth-auto680):03339 * Clear the compile state bit(s) (shift to interpret).
+1BD9 C1 (fig-forth-auto680):03340 FCB $C1 [ immediate
+1BDA DB (fig-forth-auto680):03341 FCB $DB
+1BDB 1BBD (fig-forth-auto680):03342 FDB COMPIL-10
+1BDD 17B9183D1958178A (fig-forth-auto680):03343 LBRAK FDB DOCOL,ZERO,STATE,STORE
+1BE5 1667 (fig-forth-auto680):03344 FDB SEMIS
+ (fig-forth-auto680):03345 *
+ (fig-forth-auto680):03346 * ======>> 113 <<
+ (fig-forth-auto680):03347 *
+ 00C0 (fig-forth-auto680):03348 STCOMP EQU $C0
+ (fig-forth-auto680):03349 * ( --- )
+ (fig-forth-auto680):03350 * Set the compile state bit(s) (shift to compile).
+1BE7 81 (fig-forth-auto680):03351 FCB $81 ]
+1BE8 DD (fig-forth-auto680):03352 FCB $DD
+1BE9 1BD9 (fig-forth-auto680):03353 FDB LBRAK-4
+1BEB 17B913A7 (fig-forth-auto680):03354 RBRAK FDB DOCOL,LIT8
+1BEF C0 (fig-forth-auto680):03355 FCB STCOMP
+1BF0 1958178A (fig-forth-auto680):03356 FDB STATE,STORE
+1BF4 1667 (fig-forth-auto680):03357 FDB SEMIS
+ (fig-forth-auto680):03358 *
+ (fig-forth-auto680):03359 * ======>> 114 <<
+ (fig-forth-auto680):03360 * ( --- )
+ (fig-forth-auto680):03361 * Toggle SMUDGE bit of LATEST definition header,
+ (fig-forth-auto680):03362 * to hide it until defined or reveal it after definition.
+1BF6 86 (fig-forth-auto680):03363 FCB $86
+1BF7 534D554447 (fig-forth-auto680):03364 FCC 'SMUDG' ; 'SMUDGE'
+1BFC C5 (fig-forth-auto680):03365 FCB $C5
+1BFD 1BE7 (fig-forth-auto680):03366 FDB RBRAK-4
+1BFF 17B91AD013A7 (fig-forth-auto680):03367 SMUDGE FDB DOCOL,LATEST,LIT8
+1C05 20 (fig-forth-auto680):03368 FCB FSMUDG
+1C06 1765 (fig-forth-auto680):03369 FDB TOGGLE
+1C08 1667 (fig-forth-auto680):03370 FDB SEMIS
+ (fig-forth-auto680):03371 *
+ (fig-forth-auto680):03372 * ======>> 115 <<
+ (fig-forth-auto680):03373 * ( --- )
+ (fig-forth-auto680):03374 * Set the conversion base to sixteen (b00010000).
+1C0A 83 (fig-forth-auto680):03375 FCB $83
+1C0B 4845 (fig-forth-auto680):03376 FCC 'HE' ; 'HEX'
+1C0D D8 (fig-forth-auto680):03377 FCB $D8
+1C0E 1BF6 (fig-forth-auto680):03378 FDB SMUDGE-9
+1C10 17B9 (fig-forth-auto680):03379 HEX FDB DOCOL
+1C12 13A7 (fig-forth-auto680):03380 FDB LIT8
+1C14 10 (fig-forth-auto680):03381 FCB 16 ; decimal sixteen
+1C15 1963178A (fig-forth-auto680):03382 FDB BASE,STORE
+1C19 1667 (fig-forth-auto680):03383 FDB SEMIS
+ (fig-forth-auto680):03384 *
+ (fig-forth-auto680):03385 * ======>> 116 <<
+ (fig-forth-auto680):03386 * ( --- )
+ (fig-forth-auto680):03387 * Set the conversion base to ten (b00001010).
+1C1B 87 (fig-forth-auto680):03388 FCB $87
+1C1C 444543494D41 (fig-forth-auto680):03389 FCC 'DECIMA' ; 'DECIMAL'
+1C22 CC (fig-forth-auto680):03390 FCB $CC
+1C23 1C0A (fig-forth-auto680):03391 FDB HEX-6
+1C25 17B9 (fig-forth-auto680):03392 DEC FDB DOCOL
+1C27 13A7 (fig-forth-auto680):03393 FDB LIT8
+1C29 0A (fig-forth-auto680):03394 FCB 10 ; decimal ten
+1C2A 1963178A (fig-forth-auto680):03395 FDB BASE,STORE
+1C2E 1667 (fig-forth-auto680):03396 FDB SEMIS
+ (fig-forth-auto680):03397 *
+ (fig-forth-auto680):03398 * ######>> screen 42 <<
+ (fig-forth-auto680):03399 * ======>> 117 <<
+ (fig-forth-auto680):03400 * ( --- ) ( IP *** )
+ (fig-forth-auto680):03401 * Pop the saved IP and use it to
+ (fig-forth-auto680):03402 * compile the latest symbol as a reference to a ;CODE definition;
+ (fig-forth-auto680):03403 * overwrite the code field of the symbol found by LATEST
+ (fig-forth-auto680):03404 * with the address of the low-level characteristic code
+ (fig-forth-auto680):03405 * provided in the defining definition.
+ (fig-forth-auto680):03406 * Look closely at where things return, consider the operation of R> and >R .
+ (fig-forth-auto680):03407 *
+ (fig-forth-auto680):03408 * The machine-level code which follows (;CODE) in the instruction stream
+ (fig-forth-auto680):03409 * is not executed by the defining symbol,
+ (fig-forth-auto680):03410 * but becomes the characteristic of the defined symbol.
+ (fig-forth-auto680):03411 * This is the usual way to generate the characteristics of VARIABLEs,
+ (fig-forth-auto680):03412 * CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
+ (fig-forth-auto680):03413 *
+ (fig-forth-auto680):03414 * Finally, note that, if code shifts from low level back to high
+ (fig-forth-auto680):03415 * (native CPU machine code calling into a list of FORTH codes),
+ (fig-forth-auto680):03416 * the low level code can't just call a high-level definition.
+ (fig-forth-auto680):03417 * Leaf definitions can directly call other leaf definitions,
+ (fig-forth-auto680):03418 * but not non-leafs.
+ (fig-forth-auto680):03419 * It will need an anonymous list, probably embedded in the low-level code,
+ (fig-forth-auto680):03420 * and Y and X will have to be set appropriately before entering the list.
+1C30 87 (fig-forth-auto680):03421 FCB $87
+1C31 283B434F4445 (fig-forth-auto680):03422 FCC '(;CODE' ; '(;CODE)'
+1C37 A9 (fig-forth-auto680):03423 FCB $A9
+1C38 1C1B (fig-forth-auto680):03424 FDB DEC-10
+ (fig-forth-auto680):03425 * PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
+1C3A 17B91690 (fig-forth-auto680):03426 PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+1C3E 1AD01B121AEF178A (fig-forth-auto680):03427 FDB LATEST,PFA,CFA,STORE
+1C46 1667 (fig-forth-auto680):03428 FDB SEMIS
+ (fig-forth-auto680):03429 *
+ (fig-forth-auto680):03430 * ======>> 118 <<
+ (fig-forth-auto680):03431 * ( --- ) P
+ (fig-forth-auto680):03432 * ?CSP to see if there are loose ends in the defining definition
+ (fig-forth-auto680):03433 * before shifting to the assembler,
+ (fig-forth-auto680):03434 * compile (;CODE) in the defining definition's instruction stream,
+ (fig-forth-auto680):03435 * shift to interpreting,
+ (fig-forth-auto680):03436 * make the ASSEMBLER vocabulary current,
+ (fig-forth-auto680):03437 * and !CSP to mark the stack
+ (fig-forth-auto680):03438 * in preparation for assembling low-level code.
+ (fig-forth-auto680):03439 * Note that ;CODE, unlike DOES>, is IMMEDIATE,
+ (fig-forth-auto680):03440 * and compiles (;CODE),
+ (fig-forth-auto680):03441 * which will do the actual work of changing
+ (fig-forth-auto680):03442 * the LATEST definition's characteristic when the defining word runs.
+ (fig-forth-auto680):03443 * Assembly is done by the interpreter, rather than the compiler.
+ (fig-forth-auto680):03444 * I could have avoided the anomalous three-byte code fields by
+ (fig-forth-auto680):03445 *
+ (fig-forth-auto680):03446 * Note that the ASSEMBLER is not part of the model (at this time).
+ (fig-forth-auto680):03447 * That means that, until the assembler is ready,
+ (fig-forth-auto680):03448 * if you want to define low-level words,
+ (fig-forth-auto680):03449 * you have to poke (comma) in hand-assembled stuff.
+ (fig-forth-auto680):03450 *
+1C48 C5 (fig-forth-auto680):03451 FCB $C5 immediate
+1C49 3B434F44 (fig-forth-auto680):03452 FCC ';COD' ; ';CODE'
+1C4D C5 (fig-forth-auto680):03453 FCB $C5
+1C4E 1C30 (fig-forth-auto680):03454 FDB PSCODE-10
+1C50 17B91B921BC71C3A (fig-forth-auto680):03455 SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
+ 1BFF1BDD1D5B
+1C5E 1667 (fig-forth-auto680):03456 FDB SEMIS
+ (fig-forth-auto680):03457 * note: "QSTACK" will be replaced by "ASSEMBLER" later
+ (fig-forth-auto680):03458 *
+ (fig-forth-auto680):03459 * ######>> screen 43 <<
+ (fig-forth-auto680):03460 * ======>> 119 <<
+ (fig-forth-auto680):03461 * ( --- ) C
+ (fig-forth-auto680):03462 * Make the word currently being defined
+ (fig-forth-auto680):03463 * build a header for DOES> definitions.
+ (fig-forth-auto680):03464 * Actually just compiles a CONSTANT zero
+ (fig-forth-auto680):03465 * which can be overwritten later by DOES>.
+ (fig-forth-auto680):03466 * Since the fig models were established, this technique has been deprecated.
+ (fig-forth-auto680):03467 *
+ (fig-forth-auto680):03468 * Note that <BUILDS is not IMMEDIATE,
+ (fig-forth-auto680):03469 * and therefore executes during a definition's run-time,
+ (fig-forth-auto680):03470 * rather than its compile-time.
+ (fig-forth-auto680):03471 * It is not intended to be used directly,
+ (fig-forth-auto680):03472 * but rather so that one definition word can build another.
+ (fig-forth-auto680):03473 * Also, note that nothing particularly special happens
+ (fig-forth-auto680):03474 * in the defining definition until DOES> executes.
+ (fig-forth-auto680):03475 * The name <BUILDS is intended to be a reminder of what is about to occur.
+ (fig-forth-auto680):03476 *
+ (fig-forth-auto680):03477 * <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
+1C60 87 (fig-forth-auto680):03478 FCB $87
+1C61 3C4255494C44 (fig-forth-auto680):03479 FCC '<BUILD' ; '<BUILDS'
+1C67 D3 (fig-forth-auto680):03480 FCB $D3
+1C68 1C48 (fig-forth-auto680):03481 FDB SEMIC-8
+1C6A 17B9183D17DF (fig-forth-auto680):03482 BUILDS FDB DOCOL,ZERO,CON
+1C70 1667 (fig-forth-auto680):03483 FDB SEMIS
+ (fig-forth-auto680):03484 *
+ (fig-forth-auto680):03485 * ======>> 120 <<
+ (fig-forth-auto680):03486 * ( --- ) ( IP *** ) C
+ (fig-forth-auto680):03487 * Define run-time behavior of definitions compiled/defined
+ (fig-forth-auto680):03488 * by a high-level defining definition --
+ (fig-forth-auto680):03489 * the FORTH equivalent of a compiler-compiler.
+ (fig-forth-auto680):03490 * DOES> assumes that the LATEST symbol table entry
+ (fig-forth-auto680):03491 * has at least one word of parameter field,
+ (fig-forth-auto680):03492 * which <BUILDS provides.
+ (fig-forth-auto680):03493 * Note that DOES> is also not IMMEDIATE.
+ (fig-forth-auto680):03494 *
+ (fig-forth-auto680):03495 * When the defining word containing DOES> executes the DOES> icode,
+ (fig-forth-auto680):03496 * it overwrites the LATEST symbol's CFA with jsr <XDOES,
+ (fig-forth-auto680):03497 * overwrites the first word of that symbol's parameter field with its own IP,
+ (fig-forth-auto680):03498 * and pops the previous IP from the return stack.
+ (fig-forth-auto680):03499 * The icodes which follow DOES> in the stream
+ (fig-forth-auto680):03500 * do not execute at the defining word's run-time.
+ (fig-forth-auto680):03501 *
+ (fig-forth-auto680):03502 * Examining XDOES in the virtual machine shows
+ (fig-forth-auto680):03503 * that the defined word will execute those icodes
+ (fig-forth-auto680):03504 * which follow DOES> at its own run-time.
+ (fig-forth-auto680):03505 *
+ (fig-forth-auto680):03506 * The advantage of this kind of behaviour,
+ (fig-forth-auto680):03507 * which you will also note in ;CODE,
+ (fig-forth-auto680):03508 * is that the defined word can contain
+ (fig-forth-auto680):03509 * both operations and data to be operated on.
+ (fig-forth-auto680):03510 * This is how FORTH data objects define their own behavior.
+ (fig-forth-auto680):03511 *
+ (fig-forth-auto680):03512 * Finally, note that the effective parameter field for DOES> definitions
+ (fig-forth-auto680):03513 * starts two NATWID words after the CFA, instead of just one
+ (fig-forth-auto680):03514 * (four bytes instead of two in a sixteen-bit addressing Forth).
+ (fig-forth-auto680):03515 *
+ (fig-forth-auto680):03516 * VOCABULARYs will use this. See definition of word FORTH.
+1C72 85 (fig-forth-auto680):03517 FCB $85
+1C73 444F4553 (fig-forth-auto680):03518 FCC 'DOES' ; 'DOES>'
+1C77 BE (fig-forth-auto680):03519 FCB $BE
+1C78 1C60 (fig-forth-auto680):03520 FDB BUILDS-10
+ (fig-forth-auto680):03521 * DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
+1C7A 17B91690 (fig-forth-auto680):03522 DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+1C7E 1AD01B12178A (fig-forth-auto680):03523 FDB LATEST,PFA,STORE
+1C84 1C3A (fig-forth-auto680):03524 FDB PSCODE
+ (fig-forth-auto680):03525 *
+ (fig-forth-auto680):03526 * ( --- PFA+NATWID ) ( *** IP )
+ (fig-forth-auto680):03527 * Characteristic of a DOES> defined word.
+ (fig-forth-auto680):03528 * The characteristics of DOES> definitions are written in high-level
+ (fig-forth-auto680):03529 * Forth codes rather than native CPU machine level code.
+ (fig-forth-auto680):03530 * The first parameter word points to the high-level characteristic.
+ (fig-forth-auto680):03531 * This routine's job is to push the IP,
+ (fig-forth-auto680):03532 * load the high level characteristic pointer in IP,
+ (fig-forth-auto680):03533 * and leave the address following the characteristic pointer on the stack
+ (fig-forth-auto680):03534 * so the parameter field can be accessed.
+1C86 ECE4 (fig-forth-auto680):03535 DODOES LDD ,S ; Keep the return address.
+1C88 10AFE4 (fig-forth-auto680):03536 STY ,S ; Save/nest the current IP on the return stack.
+1C8B 10AE02 (fig-forth-auto680):03537 LDY NATWID,X ; First parameter is new IP.
+1C8E 3004 (fig-forth-auto680):03538 LEAX 2*NATWID,X ; Address of second parameter.
+1C90 3610 (fig-forth-auto680):03539 PSHU X
+1C92 1F05 (fig-forth-auto680):03540 TFR D,PC ; Synthetic return.
+ (fig-forth-auto680):03541 *
+ (fig-forth-auto680):03542 * From the 6800 model:
+ (fig-forth-auto680):03543 * DODOES LDA IP
+ (fig-forth-auto680):03544 * LDB IP+1
+ (fig-forth-auto680):03545 * LDX RP make room on return stack
+ (fig-forth-auto680):03546 * LEAX -1,X ;
+ (fig-forth-auto680):03547 * LEAX -1,X ;
+ (fig-forth-auto680):03548 * STX RP
+ (fig-forth-auto680):03549 * STA 2,X push return address
+ (fig-forth-auto680):03550 * STB 3,X
+ (fig-forth-auto680):03551 * LDX W get addr of pointer to run-time code
+ (fig-forth-auto680):03552 * LEAX 1,X ;
+ (fig-forth-auto680):03553 * LEAX 1,X ;
+ (fig-forth-auto680):03554 * STX N stash it in scratch area
+ (fig-forth-auto680):03555 * LDX 0,X get new IP
+ (fig-forth-auto680):03556 * STX IP
+ (fig-forth-auto680):03557 * CLRA ; get address of parameter
+ (fig-forth-auto680):03558 * LDB #2
+ (fig-forth-auto680):03559 * ADDB N+1
+ (fig-forth-auto680):03560 * ADCA N
+ (fig-forth-auto680):03561 * PSHS B ; and push it on data stack
+ (fig-forth-auto680):03562 * PSHS A ;
+ (fig-forth-auto680):03563 * JMP NEXT2
+ (fig-forth-auto680):03564 *
+ (fig-forth-auto680):03565 * ######>> screen 44 <<
+ (fig-forth-auto680):03566 * ======>> 121 <<
+ (fig-forth-auto680):03567 * ( strptr --- strptr+1 count )
+ (fig-forth-auto680):03568 * Convert counted string to string and count.
+ (fig-forth-auto680):03569 * (Fetch the byte at strptr, post-increment.)
+1C94 85 (fig-forth-auto680):03570 FCB $85
+1C95 434F554E (fig-forth-auto680):03571 FCC 'COUN' ; 'COUNT'
+1C99 D4 (fig-forth-auto680):03572 FCB $D4
+1C9A 1C72 (fig-forth-auto680):03573 FDB DOES-8
+1C9C 17B9174519AB1736 (fig-forth-auto680):03574 COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
+ 177E
+1CA6 1667 (fig-forth-auto680):03575 FDB SEMIS
+ (fig-forth-auto680):03576 *
+ (fig-forth-auto680):03577 * ======>> 122 <<
+ (fig-forth-auto680):03578 * ( strptr count --- )
+ (fig-forth-auto680):03579 * EMIT count characters at strptr.
+1CA8 84 (fig-forth-auto680):03580 FCB $84
+1CA9 545950 (fig-forth-auto680):03581 FCC 'TYP' ; 'TYPE'
+1CAC C5 (fig-forth-auto680):03582 FCB $C5
+1CAD 1C94 (fig-forth-auto680):03583 FDB COUNT-8
+1CAF 17B91A8A1409 (fig-forth-auto680):03584 TYPE FDB DOCOL,DDUP,ZBRAN
+1CB5 0016 (fig-forth-auto680):03585 FDB TYPE3-*-NATWID
+1CB7 171C16C617361453 (fig-forth-auto680):03586 FDB OVER,PLUS,SWAP,XDO
+1CBF 1465177E1542141D (fig-forth-auto680):03587 TYPE2 FDB I,CAT,EMIT,XLOOP
+1CC7 FFF6 (fig-forth-auto680):03588 FDB TYPE2-*-NATWID
+1CC9 13FA (fig-forth-auto680):03589 FDB BRAN
+1CCB 0002 (fig-forth-auto680):03590 FDB TYPE4-*-NATWID
+1CCD 172A (fig-forth-auto680):03591 TYPE3 FDB DROP
+1CCF 1667 (fig-forth-auto680):03592 TYPE4 FDB SEMIS
+ (fig-forth-auto680):03593 *
+ (fig-forth-auto680):03594 * ======>> 123 <<
+ (fig-forth-auto680):03595 * ( strptr count1 --- strptr count2 )
+ (fig-forth-auto680):03596 * Supress trailing blanks (subtract count of trailing blanks from strptr).
+1CD1 89 (fig-forth-auto680):03597 FCB $89
+1CD2 2D545241494C494E (fig-forth-auto680):03598 FCC '-TRAILIN' ; '-TRAILING'
+1CDA C7 (fig-forth-auto680):03599 FCB $C7
+1CDB 1CA8 (fig-forth-auto680):03600 FDB TYPE-7
+1CDD 17B91745183D1453 (fig-forth-auto680):03601 DTRAIL FDB DOCOL,DUP,ZERO,XDO
+1CE5 171C171C16C61845 (fig-forth-auto680):03602 DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
+ 1A04177E185E
+1CF3 1A041409 (fig-forth-auto680):03603 FDB SUB,ZBRAN
+1CF7 0006 (fig-forth-auto680):03604 FDB DTRAL3-*-NATWID
+1CF9 167513FA (fig-forth-auto680):03605 FDB LEAVE,BRAN
+1CFD 0004 (fig-forth-auto680):03606 FDB DTRAL4-*-NATWID
+1CFF 18451A04 (fig-forth-auto680):03607 DTRAL3 FDB ONE,SUB
+1D03 141D (fig-forth-auto680):03608 DTRAL4 FDB XLOOP
+1D05 FFDE (fig-forth-auto680):03609 FDB DTRAL2-*-NATWID
+1D07 1667 (fig-forth-auto680):03610 FDB SEMIS
+ (fig-forth-auto680):03611 *
+ (fig-forth-auto680):03612 * ======>> 124 <<
+ (fig-forth-auto680):03613 * ( --- )
+ (fig-forth-auto680):03614 * TYPE counted string out of instruction stream (updating IP).
+1D09 84 (fig-forth-auto680):03615 FCB $84
+1D0A 282E22 (fig-forth-auto680):03616 FCC '(."' ; '(.")'
+1D0D A9 (fig-forth-auto680):03617 FCB $A9
+1D0E 1CD1 (fig-forth-auto680):03618 FDB DTRAIL-12
+ (fig-forth-auto680):03619 * PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
+ (fig-forth-auto680):03620 * PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
+1D10 17B9169C1C9C1745 (fig-forth-auto680):03621 PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP
+ 19AB
+1D1A 169016C616811CAF (fig-forth-auto680):03622 FDB FROMR,PLUS,TOR,TYPE
+1D22 1667 (fig-forth-auto680):03623 FDB SEMIS
+ (fig-forth-auto680):03624 *
+ (fig-forth-auto680):03625 * ======>> 125 <<
+ (fig-forth-auto680):03626 * ( --- ) P
+ (fig-forth-auto680):03627 * { ." something-to-be-printed " } typical input
+ (fig-forth-auto680):03628 * Use WORD to parse to trailing quote;
+ (fig-forth-auto680):03629 * if compiling, compile XDOTQ and string parsed,
+ (fig-forth-auto680):03630 * otherwise, TYPE string.
+1D24 C2 (fig-forth-auto680):03631 FCB $C2 immediate
+1D25 2E (fig-forth-auto680):03632 FCC '.' ; '."'
+1D26 A2 (fig-forth-auto680):03633 FCB $A2
+1D27 1D09 (fig-forth-auto680):03634 FDB PDOTQ-7
+1D29 17B9 (fig-forth-auto680):03635 DOTQ FDB DOCOL
+1D2B 13A7 (fig-forth-auto680):03636 FDB LIT8
+1D2D 22 (fig-forth-auto680):03637 FCB $22 ascii quote
+1D2E 195817721409 (fig-forth-auto680):03638 FDB STATE,AT,ZBRAN
+1D34 0012 (fig-forth-auto680):03639 FDB DOTQ1-*-NATWID
+1D36 1BC71D101EBC (fig-forth-auto680):03640 FDB COMPIL,PDOTQ,WORD
+1D3C 19C7177E19AB19D7 (fig-forth-auto680):03641 FDB HERE,CAT,ONEP,ALLOT,BRAN
+ 13FA
+1D46 0008 (fig-forth-auto680):03642 FDB DOTQ2-*-NATWID
+1D48 1EBC19C71C9C1CAF (fig-forth-auto680):03643 DOTQ1 FDB WORD,HERE,COUNT,TYPE
+1D50 1667 (fig-forth-auto680):03644 DOTQ2 FDB SEMIS
+ (fig-forth-auto680):03645 *
+ (fig-forth-auto680):03646 * ######>> screen 45 <<
+ (fig-forth-auto680):03647 * ======>> 126 <<== MACHINE DEPENDENT
+ (fig-forth-auto680):03648 * ( --- ) ( *** )
+ (fig-forth-auto680):03649 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03650 * ERROR if parameter stack out of bounds.
+ (fig-forth-auto680):03651 *
+ (fig-forth-auto680):03652 * But checking whether the stack is in bounds or not
+ (fig-forth-auto680):03653 * really should not use the stack.
+ (fig-forth-auto680):03654 * And there really should be a ?RSTACK, as well.
+1D52 86 (fig-forth-auto680):03655 FCB $86
+1D53 3F53544143 (fig-forth-auto680):03656 FCC '?STAC' ; '?STACK'
+1D58 CB (fig-forth-auto680):03657 FCB $CB
+1D59 1D24 (fig-forth-auto680):03658 FDB DOTQ-5
+1D5B 17B913A7 (fig-forth-auto680):03659 QSTACK FDB DOCOL,LIT8
+ (fig-forth-auto680):03660 * FCB $12
+1D5F 12 (fig-forth-auto680):03661 FCB SINIT-ORIG
+ (fig-forth-auto680):03662 * But why use that instead of XSPZER (S0)?
+ (fig-forth-auto680):03663 * Multi-user or multi-tasking would not want that.
+ (fig-forth-auto680):03664 * CMPU <XSPZER
+ (fig-forth-auto680):03665 * FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
+1D60 189C177216401A1D (fig-forth-auto680):03666 FDB PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
+ 1845
+1D6A 1B39 (fig-forth-auto680):03667 FDB QERR
+ (fig-forth-auto680):03668 * prints 'empty stack'
+ (fig-forth-auto680):03669 *
+1D6C 1640 (fig-forth-auto680):03670 QSTAC2 FDB SPAT
+ (fig-forth-auto680):03671 * Here, we compare with a value at least 128
+ (fig-forth-auto680):03672 * higher than dict. ptr. (DICTPT)
+1D6E 19C713A7 (fig-forth-auto680):03673 FDB HERE,LIT8
+1D72 80 (fig-forth-auto680):03674 FCB $80 ; This is a rough check anyway, leave it as is.
+1D73 16C61A1D1409 (fig-forth-auto680):03675 FDB PLUS,LESS,ZBRAN
+1D79 0004 (fig-forth-auto680):03676 FDB QSTAC3-*-NATWID
+1D7B 184D (fig-forth-auto680):03677 FDB TWO ; NOT the NATWID constant!
+1D7D 1B39 (fig-forth-auto680):03678 FDB QERR
+ (fig-forth-auto680):03679 * prints 'full stack'
+ (fig-forth-auto680):03680 *
+1D7F 1667 (fig-forth-auto680):03681 QSTAC3 FDB SEMIS
+ (fig-forth-auto680):03682 *
+ (fig-forth-auto680):03683 * ======>> 127 << this word's function
+ (fig-forth-auto680):03684 * is done by ?STACK in this version
+ (fig-forth-auto680):03685 * FCB $85
+ (fig-forth-auto680):03686 * FCC 4,?FREE
+ (fig-forth-auto680):03687 * FCB $C5
+ (fig-forth-auto680):03688 * FDB QSTACK-9
+ (fig-forth-auto680):03689 *QFREE FDB DOCOL,SPAT,HERE,LIT8
+ (fig-forth-auto680):03690 * FCB $80
+ (fig-forth-auto680):03691 * FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
+ (fig-forth-auto680):03692 *
+ (fig-forth-auto680):03693 * ######>> screen 46 <<
+ (fig-forth-auto680):03694 * ======>> 128 <<
+ (fig-forth-auto680):03695 * ( buffer n --- )
+ (fig-forth-auto680):03696 * ***** Check that this is how it works here:
+ (fig-forth-auto680):03697 * Get up to n-1 characters from the keyboard,
+ (fig-forth-auto680):03698 * storing at buffer and echoing, with backspace editing,
+ (fig-forth-auto680):03699 * quitting when a CR is read.
+ (fig-forth-auto680):03700 * Terminate it with a NUL.
+1D81 86 (fig-forth-auto680):03701 FCB $86
+1D82 4558504543 (fig-forth-auto680):03702 FCC 'EXPEC' ; 'EXPECT'
+1D87 D4 (fig-forth-auto680):03703 FCB $D4
+1D88 1D52 (fig-forth-auto680):03704 FDB QSTACK-9
+1D8A 17B9171C16C6171C (fig-forth-auto680):03705 EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
+ 1453
+ (fig-forth-auto680):03706 * EXPEC2 FDB KEY,DUP,LIT8
+1D94 1556 (fig-forth-auto680):03707 EXPEC2 FDB KEY
+1D96 1399001C13B9 (fig-forth-auto680):03708 FDB LIT,$1C,SHOTOS ; DBG
+1D9C 174513A7 (fig-forth-auto680):03709 FDB DUP,LIT8
+1DA0 0E (fig-forth-auto680):03710 FCB BACKSP-ORIG
+1DA1 189C17721A111409 (fig-forth-auto680):03711 FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing
+1DA9 001D (fig-forth-auto680):03712 FDB EXPEC3-*-NATWID
+1DAB 172A13A7 (fig-forth-auto680):03713 FDB DROP,LIT8
+1DAF 08 (fig-forth-auto680):03714 FCB 8 ( backspace character to emit )
+1DB0 171C14651A111745 (fig-forth-auto680):03715 FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
+ 1690184D1A0416C6
+1DC0 16811A0413FA (fig-forth-auto680):03716 FDB TOR,SUB,BRAN
+1DC6 0025 (fig-forth-auto680):03717 FDB EXPEC6-*-NATWID
+1DC8 174513A7 (fig-forth-auto680):03718 EXPEC3 FDB DUP,LIT8
+1DCC 0D (fig-forth-auto680):03719 FCB $D ( carriage return )
+1DCD 1A111409 (fig-forth-auto680):03720 FDB EQUAL,ZBRAN
+1DD1 000C (fig-forth-auto680):03721 FDB EXPEC4-*-NATWID
+1DD3 1675172A185E183D (fig-forth-auto680):03722 FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
+ 13FA
+1DDD 0002 (fig-forth-auto680):03723 FDB EXPEC5-*-NATWID
+1DDF 1745 (fig-forth-auto680):03724 EXPEC4 FDB DUP
+1DE1 14651798183D1465 (fig-forth-auto680):03725 EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
+ 19AB178A
+1DED 1542141D (fig-forth-auto680):03726 EXPEC6 FDB EMIT,XLOOP
+1DF1 FFA1 (fig-forth-auto680):03727 FDB EXPEC2-*-NATWID
+1DF3 172A (fig-forth-auto680):03728 FDB DROP
+1DF5 1667 (fig-forth-auto680):03729 FDB SEMIS
+ (fig-forth-auto680):03730 *
+ (fig-forth-auto680):03731 * ======>> 129 <<
+ (fig-forth-auto680):03732 * ( --- )
+ (fig-forth-auto680):03733 * EXPECT 128 (TWID) characters to TIB.
+1DF7 85 (fig-forth-auto680):03734 FCB $85
+1DF8 51554552 (fig-forth-auto680):03735 FCC 'QUER' ; 'QUERY'
+1DFC D9 (fig-forth-auto680):03736 FCB $D9
+1DFD 1D81 (fig-forth-auto680):03737 FDB EXPECT-9
+1DFF 17B918BE177219A2 (fig-forth-auto680):03738 QUERY FDB DOCOL,TIB,AT,COLUMS
+1E07 17721D8A183D190F (fig-forth-auto680):03739 FDB AT,EXPECT,ZERO,IN,STORE
+ 178A
+1E11 1667 (fig-forth-auto680):03740 FDB SEMIS
+ (fig-forth-auto680):03741 *
+ (fig-forth-auto680):03742 * ======>> 130 <<
+ (fig-forth-auto680):03743 * ( --- ) P
+ (fig-forth-auto680):03744 * End interpretation of a line or screen, and/or prepare for a new block.
+ (fig-forth-auto680):03745 * Note that the name of this definition is an empty string,
+ (fig-forth-auto680):03746 * so it matches on the terminating NUL in the terminal or block buffer.
+1E13 C1 (fig-forth-auto680):03747 FCB $C1 immediate < carriage return >
+1E14 80 (fig-forth-auto680):03748 FCB $80
+1E15 1DF7 (fig-forth-auto680):03749 FDB QUERY-8
+1E17 17B9190617721409 (fig-forth-auto680):03750 NULL FDB DOCOL,BLK,AT,ZBRAN
+1E1F 0024 (fig-forth-auto680):03751 FDB NULL2-*-NATWID
+1E21 184519061751 (fig-forth-auto680):03752 FDB ONE,BLK,PSTORE
+1E27 183D190F178A1906 (fig-forth-auto680):03753 FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
+ 1772188E2335
+1E35 16A3 (fig-forth-auto680):03754 FDB ZEQU
+ (fig-forth-auto680):03755 * check for end of screen
+1E37 1409 (fig-forth-auto680):03756 FDB ZBRAN
+1E39 0006 (fig-forth-auto680):03757 FDB NULL1-*-NATWID
+1E3B 1B6A1690172A (fig-forth-auto680):03758 FDB QEXEC,FROMR,DROP
+1E41 13FA (fig-forth-auto680):03759 NULL1 FDB BRAN
+1E43 0004 (fig-forth-auto680):03760 FDB NULL3-*-NATWID
+1E45 1690172A (fig-forth-auto680):03761 NULL2 FDB FROMR,DROP
+1E49 1667 (fig-forth-auto680):03762 NULL3 FDB SEMIS
+ (fig-forth-auto680):03763 *
+ (fig-forth-auto680):03764 * ######>> screen 47 <<
+ (fig-forth-auto680):03765 * ======>> 133 <<
+ (fig-forth-auto680):03766 * ( adr n b --- )
+ (fig-forth-auto680):03767 * Fill n bytes at adr with b.
+1E4B 84 (fig-forth-auto680):03768 FCB $84
+1E4C 46494C (fig-forth-auto680):03769 FCC 'FIL' ; 'FILL'
+1E4F CC (fig-forth-auto680):03770 FCB $CC
+1E50 1E13 (fig-forth-auto680):03771 FDB NULL-4
+1E52 17B917361681171C (fig-forth-auto680):03772 FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
+ 1798174519AB
+1E60 169018451A041584 (fig-forth-auto680):03773 FDB FROMR,ONE,SUB,CMOVE
+1E68 1667 (fig-forth-auto680):03774 FDB SEMIS
+ (fig-forth-auto680):03775 *
+ (fig-forth-auto680):03776 * ======>> 134 <<
+ (fig-forth-auto680):03777 * ( adr n --- )
+ (fig-forth-auto680):03778 * Fill n bytes with 0.
+1E6A 85 (fig-forth-auto680):03779 FCB $85
+1E6B 45524153 (fig-forth-auto680):03780 FCC 'ERAS' ; 'ERASE'
+1E6F C5 (fig-forth-auto680):03781 FCB $C5
+1E70 1E4B (fig-forth-auto680):03782 FDB FILL-7
+1E72 17B9183D1E52 (fig-forth-auto680):03783 ERASE FDB DOCOL,ZERO,FILL
+1E78 1667 (fig-forth-auto680):03784 FDB SEMIS
+ (fig-forth-auto680):03785 *
+ (fig-forth-auto680):03786 * ======>> 135 <<
+ (fig-forth-auto680):03787 * ( adr n --- )
+ (fig-forth-auto680):03788 * Fill n bytes with ASCII SPACE.
+1E7A 86 (fig-forth-auto680):03789 FCB $86
+1E7B 424C414E4B (fig-forth-auto680):03790 FCC 'BLANK' ; 'BLANKS'
+1E80 D3 (fig-forth-auto680):03791 FCB $D3
+1E81 1E6A (fig-forth-auto680):03792 FDB ERASE-8
+1E83 17B9185E1E52 (fig-forth-auto680):03793 BLANKS FDB DOCOL,BL,FILL
+1E89 1667 (fig-forth-auto680):03794 FDB SEMIS
+ (fig-forth-auto680):03795 *
+ (fig-forth-auto680):03796 * ======>> 136 <<
+ (fig-forth-auto680):03797 * ( c --- )
+ (fig-forth-auto680):03798 * Format a character at the left of the HLD output buffer.
+1E8B 84 (fig-forth-auto680):03799 FCB $84
+1E8C 484F4C (fig-forth-auto680):03800 FCC 'HOL' ; 'HOLD'
+1E8F C4 (fig-forth-auto680):03801 FCB $C4
+1E90 1E7A (fig-forth-auto680):03802 FDB BLANKS-9
+1E92 17B91399FFFF1994 (fig-forth-auto680):03803 HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
+ 1751199417721798
+1EA2 1667 (fig-forth-auto680):03804 FDB SEMIS
+ (fig-forth-auto680):03805 *
+ (fig-forth-auto680):03806 * ======>> 137 <<
+ (fig-forth-auto680):03807 * ( --- adr )
+ (fig-forth-auto680):03808 * Give the address of the output PAD buffer.
+ (fig-forth-auto680):03809 * PAD points to the end of a 68 byte buffer for numeric conversion.
+1EA4 83 (fig-forth-auto680):03810 FCB $83
+1EA5 5041 (fig-forth-auto680):03811 FCC 'PA' ; 'PAD'
+1EA7 C4 (fig-forth-auto680):03812 FCB $C4
+1EA8 1E8B (fig-forth-auto680):03813 FDB HOLD-7
+1EAA 17B919C713A7 (fig-forth-auto680):03814 PAD FDB DOCOL,HERE,LIT8
+1EB0 44 (fig-forth-auto680):03815 FCB $44
+1EB1 16C6 (fig-forth-auto680):03816 FDB PLUS
+1EB3 1667 (fig-forth-auto680):03817 FDB SEMIS
+ (fig-forth-auto680):03818 *
+ (fig-forth-auto680):03819 * ######>> screen 48 <<
+ (fig-forth-auto680):03820 * ======>> 138 <<
+ (fig-forth-auto680):03821 * ( c --- )
+ (fig-forth-auto680):03822 * Scan a string terminated by the character c or ASCII NUL out of input;
+ (fig-forth-auto680):03823 * store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
+ (fig-forth-auto680):03824 * Leading c are passed over, per ENCLOSE.
+ (fig-forth-auto680):03825 * Scans from BLK, or from TIB if BLK is zero.
+ (fig-forth-auto680):03826 * May overwrite the numeric conversion pad,
+ (fig-forth-auto680):03827 * if really long (length > 31) symbols are scanned.
+1EB5 84 (fig-forth-auto680):03828 FCB $84
+1EB6 574F52 (fig-forth-auto680):03829 FCC 'WOR' ; 'WORD'
+1EB9 C4 (fig-forth-auto680):03830 FCB $C4
+1EBA 1EA4 (fig-forth-auto680):03831 FDB PAD-6
+1EBC 17B9190617721409 (fig-forth-auto680):03832 WORD FDB DOCOL,BLK,AT,ZBRAN
+1EC4 000A (fig-forth-auto680):03833 FDB WORD2-*-NATWID
+1EC6 19061772249213FA (fig-forth-auto680):03834 FDB BLK,AT,BLOCK,BRAN
+1ECE 0004 (fig-forth-auto680):03835 FDB WORD3-*-NATWID
+1ED0 18BE1772 (fig-forth-auto680):03836 WORD2 FDB TIB,AT
+1ED4 190F177216C61736 (fig-forth-auto680):03837 WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
+ 14FD19C713A7
+1EE2 22 (fig-forth-auto680):03838 FCB 34
+1EE3 1E83190F1751171C (fig-forth-auto680):03839 FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
+ 1A041681169C19C7
+1EF3 179816C619C719AB (fig-forth-auto680):03840 FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
+ 16901584
+1EFF 1667 (fig-forth-auto680):03841 FDB SEMIS
+ (fig-forth-auto680):03842 *
+ (fig-forth-auto680):03843 * ######>> screen 49 <<
+ (fig-forth-auto680):03844 * ======>> 139 <<
+ (fig-forth-auto680):03845 * ( d1 string --- d2 adr )
+ (fig-forth-auto680):03846 * Convert the text at string into a number, accumulating the result into d1,
+ (fig-forth-auto680):03847 * leaving adr pointing to the first character not converted.
+ (fig-forth-auto680):03848 * If DPL is non-negative at entry,
+ (fig-forth-auto680):03849 * accumulates the number of characters converted into DPL.
+1F01 88 (fig-forth-auto680):03850 FCB $88
+1F02 284E554D424552 (fig-forth-auto680):03851 FCC '(NUMBER' ; '(NUMBER)'
+1F09 A9 (fig-forth-auto680):03852 FCB $A9
+1F0A 1EB5 (fig-forth-auto680):03853 FDB WORD-7
+1F0C 17B9 (fig-forth-auto680):03854 PNUMB FDB DOCOL
+1F0E 19AB17451681177E (fig-forth-auto680):03855 PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
+ 1963177214741409
+1F1E 002A (fig-forth-auto680):03856 FDB PNUMB4-*-NATWID
+1F20 17361963177215A5 (fig-forth-auto680):03857 FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
+ 172A1A431963
+1F2E 177215A516D4196D (fig-forth-auto680):03858 FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
+ 177219AB1409
+1F3C 0006 (fig-forth-auto680):03859 FDB PNUMB3-*-NATWID
+1F3E 1845196D1751 (fig-forth-auto680):03860 FDB ONE,DPL,PSTORE
+1F44 169013FA (fig-forth-auto680):03861 PNUMB3 FDB FROMR,BRAN
+1F48 FFC4 (fig-forth-auto680):03862 FDB PNUMB2-*-NATWID
+1F4A 1690 (fig-forth-auto680):03863 PNUMB4 FDB FROMR
+1F4C 1667 (fig-forth-auto680):03864 FDB SEMIS
+ (fig-forth-auto680):03865 *
+ (fig-forth-auto680):03866 * ======>> 140 <<
+ (fig-forth-auto680):03867 * ( ctstr --- d )
+ (fig-forth-auto680):03868 * Convert text at ctstr to a double integer,
+ (fig-forth-auto680):03869 * taking the 0 ERROR if the conversion is not valid.
+ (fig-forth-auto680):03870 * If a decimal point is present,
+ (fig-forth-auto680):03871 * accumulate the count of digits to the decimal point's right into DPL
+ (fig-forth-auto680):03872 * (negative DPL at exit indicates single precision).
+ (fig-forth-auto680):03873 * ctstr is a counted string
+ (fig-forth-auto680):03874 * -- the first byte at ctstr is the length of the string,
+ (fig-forth-auto680):03875 * but NUMBER ignores the count and expects a NUL terminator instead.
+1F4E 86 (fig-forth-auto680):03876 FCB $86
+1F4F 4E554D4245 (fig-forth-auto680):03877 FCC 'NUMBE' ; 'NUMBER'
+1F54 D2 (fig-forth-auto680):03878 FCB $D2
+1F55 1F01 (fig-forth-auto680):03879 FDB PNUMB-11
+1F57 17B9183D183D1A43 (fig-forth-auto680):03880 NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
+ 174519AB177E13A7
+1F67 2D (fig-forth-auto680):03881 FCC "-" minus sign
+1F68 1A111745168116C6 (fig-forth-auto680):03882 FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
+ 1399FFFF
+1F74 196D178A1F0C1745 (fig-forth-auto680):03883 NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
+ 177E185E1A04
+1F82 1409 (fig-forth-auto680):03884 FDB ZBRAN
+1F84 0013 (fig-forth-auto680):03885 FDB NUMB2-*-NATWID
+1F86 1745177E13A7 (fig-forth-auto680):03886 FDB DUP,CAT,LIT8
+1F8C 2E (fig-forth-auto680):03887 FCC "."
+1F8D 1A04183D1B39183D (fig-forth-auto680):03888 FDB SUB,ZERO,QERR,ZERO,BRAN
+ 13FA
+1F97 FFDB (fig-forth-auto680):03889 FDB NUMB1-*-NATWID
+1F99 172A16901409 (fig-forth-auto680):03890 NUMB2 FDB DROP,FROMR,ZBRAN
+1F9F 0002 (fig-forth-auto680):03891 FDB NUMB3-*-NATWID
+1FA1 1702 (fig-forth-auto680):03892 FDB DMINUS
+1FA3 1667 (fig-forth-auto680):03893 NUMB3 FDB SEMIS
+ (fig-forth-auto680):03894 *
+ (fig-forth-auto680):03895 * ======>> 141 <<
+ (fig-forth-auto680):03896 * ( --- locptr length true ) { -FIND name } typical input
+ (fig-forth-auto680):03897 * ( --- false )
+ (fig-forth-auto680):03898 * Parse a word, then FIND,
+ (fig-forth-auto680):03899 * first in the definition vocabulary,
+ (fig-forth-auto680):03900 * then in the CONTEXT (interpretation) vocabulary, if necessary.
+ (fig-forth-auto680):03901 * Returns what (FIND) returns, flag and optional location and length.
+1FA5 85 (fig-forth-auto680):03902 FCB $85
+1FA6 2D46494E (fig-forth-auto680):03903 FCC '-FIN' ; '-FIND'
+1FAA C4 (fig-forth-auto680):03904 FCB $C4
+1FAB 1F4E (fig-forth-auto680):03905 FDB NUMB-9
+1FAD 17B9185E1EBC19C7 (fig-forth-auto680):03906 DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
+ 193E17721772
+1FBB 14AF174516A31409 (fig-forth-auto680):03907 FDB PFIND,DUP,ZEQU,ZBRAN
+1FC3 0008 (fig-forth-auto680):03908 FDB DFIND2-*-NATWID
+1FC5 172A19C71AD014AF (fig-forth-auto680):03909 FDB DROP,HERE,LATEST,PFIND
+1FCD 1667 (fig-forth-auto680):03910 DFIND2 FDB SEMIS
+ (fig-forth-auto680):03911 *
+ (fig-forth-auto680):03912 * ######>> screen 50 <<
+ (fig-forth-auto680):03913 * ======>> 142 <<
+ (fig-forth-auto680):03914 * ( anything --- nothing ) ( anything *** nothing )
+ (fig-forth-auto680):03915 * An indirection for ABORT, for ERROR,
+ (fig-forth-auto680):03916 * which may be modified carefully.
+1FCF 87 (fig-forth-auto680):03917 FCB $87
+1FD0 2841424F5254 (fig-forth-auto680):03918 FCC '(ABORT' ; '(ABORT)'
+1FD6 A9 (fig-forth-auto680):03919 FCB $A9
+1FD7 1FA5 (fig-forth-auto680):03920 FDB DFIND-8
+1FD9 17B92205 (fig-forth-auto680):03921 PABORT FDB DOCOL,ABORT
+1FDD 1667 (fig-forth-auto680):03922 FDB SEMIS
+ (fig-forth-auto680):03923 *
+ (fig-forth-auto680):03924 * ======>> 143 <<
+1FDF 85 (fig-forth-auto680):03925 FCB $85
+1FE0 4552524F (fig-forth-auto680):03926 FCC 'ERRO' ; 'ERROR'
+1FE4 D2 (fig-forth-auto680):03927 FCB $D2
+1FE5 1FCF (fig-forth-auto680):03928 FDB PABORT-10
+ (fig-forth-auto680):03929 * This really should not be high level, according to best practices.
+ (fig-forth-auto680):03930 * But fixing that cascades through MESSAGE,
+ (fig-forth-auto680):03931 * requiring re-architecting the disk block system.
+ (fig-forth-auto680):03932 * First, we need to get this transliteration running.
+1FE7 17B918D8177216B5 (fig-forth-auto680):03933 ERROR FDB DOCOL,WARN,AT,ZLESS
+1FEF 1409 (fig-forth-auto680):03934 FDB ZBRAN
+1FF1 0002 (fig-forth-auto680):03935 FDB ERROR2-*-NATWID
+ (fig-forth-auto680):03936 * note: WARNING is
+ (fig-forth-auto680):03937 * -1 to abort,
+ (fig-forth-auto680):03938 * 0 to print error #
+ (fig-forth-auto680):03939 * and 1 to print error message from disc
+1FF3 1FD9 (fig-forth-auto680):03940 FDB PABORT
+1FF5 19C71C9C1CAF1D10 (fig-forth-auto680):03941 ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
+1FFD 0407 (fig-forth-auto680):03942 FCB 4,7 ( bell )
+1FFF 203F20 (fig-forth-auto680):03943 FCC " ? "
+2002 252B164D190F1772 (fig-forth-auto680):03944 FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
+ 1906177221D7
+2010 1667 (fig-forth-auto680):03945 FDB SEMIS
+ (fig-forth-auto680):03946 *
+ (fig-forth-auto680):03947 * ======>> 144 <<
+ (fig-forth-auto680):03948 * ( n adr --- )
+ (fig-forth-auto680):03949 * Mask byte at adr with n.
+ (fig-forth-auto680):03950 * Not in FIG, don't need it for 8 bit characters after all.
+ (fig-forth-auto680):03951 * FCB $85
+ (fig-forth-auto680):03952 * FCC 'CMAS' ; 'CMASK'
+ (fig-forth-auto680):03953 * FCB $CB ; 'K'
+ (fig-forth-auto680):03954 * FDB ERROR-8
+ (fig-forth-auto680):03955 * CMASK FDB *+NATWID
+ (fig-forth-auto680):03956 * LDX ,U++ ; adr
+ (fig-forth-auto680):03957 * LDD ,U++ ; mask
+ (fig-forth-auto680):03958 * ANDB ,X
+ (fig-forth-auto680):03959 * STB ,X
+ (fig-forth-auto680):03960 * RTS
+ (fig-forth-auto680):03961 *
+ (fig-forth-auto680):03962 * ( adr --- adr )
+ (fig-forth-auto680):03963 * Mask high bit of tail of name in PAD buffer.
+ (fig-forth-auto680):03964 * Not in FIG, need it for 8 bit characters.
+2012 86 (fig-forth-auto680):03965 FCB $86
+2013 4944464C41 (fig-forth-auto680):03966 FCC 'IDFLA' ; 'IDFLAT'
+2018 D4 (fig-forth-auto680):03967 FCB $D4 ; 'T'
+2019 1FDF (fig-forth-auto680):03968 FDB ERROR-8
+201B 201D (fig-forth-auto680):03969 IDFLAT FDB *+NATWID
+201D AEC4 (fig-forth-auto680):03970 LDX ,U
+201F E684 (fig-forth-auto680):03971 LDB ,X ; get the count
+2021 C43F (fig-forth-auto680):03972 ANDB #CTMASK
+2023 A685 (fig-forth-auto680):03973 LDA B,X ; point to the tail
+2025 847F (fig-forth-auto680):03974 ANDA #$7F ; Clear the EndOfName flag bit.
+2027 A785 (fig-forth-auto680):03975 STA B,X
+2029 39 (fig-forth-auto680):03976 RTS
+ (fig-forth-auto680):03977 *
+ (fig-forth-auto680):03978 * ( symptr --- )
+ (fig-forth-auto680):03979 * Print definition's name from its NFA.
+202A 83 (fig-forth-auto680):03980 FCB $83
+202B 4944 (fig-forth-auto680):03981 FCC 'ID' ; 'ID.'
+202D AE (fig-forth-auto680):03982 FCB $AE
+202E 2012 (fig-forth-auto680):03983 FDB IDFLAT-9
+2030 17B91EAA13A7 (fig-forth-auto680):03984 IDDOT FDB DOCOL,PAD,LIT8
+2036 20 (fig-forth-auto680):03985 FCB 32
+2037 13A7 (fig-forth-auto680):03986 FDB LIT8
+2039 5F (fig-forth-auto680):03987 FCB $5F ( underline )
+203A 1E5217451B121AE0 (fig-forth-auto680):03988 FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
+ 171C1A041EAA
+ (fig-forth-auto680):03989 * FDB SWAP,CMOVE,PAD,COUNT,LIT8
+2048 173615841EAA (fig-forth-auto680):03990 FDB SWAP,CMOVE,PAD
+204E 201B (fig-forth-auto680):03991 FDB IDFLAT
+2050 1C9C13A7 (fig-forth-auto680):03992 FDB COUNT,LIT8
+2054 1F (fig-forth-auto680):03993 FCB 31
+2055 160E1CAF1A57 (fig-forth-auto680):03994 FDB AND,TYPE,SPACE
+205B 1667 (fig-forth-auto680):03995 FDB SEMIS
+ (fig-forth-auto680):03996 *
+ (fig-forth-auto680):03997 * ######>> screen 51 <<
+ (fig-forth-auto680):03998 * ======>> 145 <<
+ (fig-forth-auto680):03999 * ( --- ) { CREATE name } input
+ (fig-forth-auto680):04000 * Parse a name (length < 32 characters) and create a header,
+ (fig-forth-auto680):04001 * reporting first duplicate found in either the defining vocabulary
+ (fig-forth-auto680):04002 * or the context (interpreting) vocabulary.
+ (fig-forth-auto680):04003 * Install the header in the defining vocabulary
+ (fig-forth-auto680):04004 * with CFA dangerously pointing to the parameter field.
+ (fig-forth-auto680):04005 * Leave the name SMUDGEd.
+205D 86 (fig-forth-auto680):04006 FCB $86
+205E 4352454154 (fig-forth-auto680):04007 FCC 'CREAT' ; 'CREATE'
+2063 C5 (fig-forth-auto680):04008 FCB $C5
+2064 202A (fig-forth-auto680):04009 FDB IDDOT-6
+2066 17B91FAD1409 (fig-forth-auto680):04010 CREATE FDB DOCOL,DFIND,ZBRAN
+206C 0018 (fig-forth-auto680):04011 FDB CREAT2-*-NATWID
+206E 172A1D10 (fig-forth-auto680):04012 FDB DROP,PDOTQ
+2072 08 (fig-forth-auto680):04013 FCB 8
+2073 07 (fig-forth-auto680):04014 FCB 7 ( bel )
+2074 72656465663A20 (fig-forth-auto680):04015 FCC "redef: "
+207B 1AFD203013A7 (fig-forth-auto680):04016 FDB NFA,IDDOT,LIT8
+2081 04 (fig-forth-auto680):04017 FCB 4
+2082 252B1A57 (fig-forth-auto680):04018 FDB MESS,SPACE
+2086 19C71745177E18CA (fig-forth-auto680):04019 CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
+ 17721A65
+2092 19AB19D7174513A7 (fig-forth-auto680):04020 FDB ONEP,ALLOT,DUP,LIT8
+209A A0 (fig-forth-auto680):04021 FCB ($80|FSMUDG) ; Bracket the name.
+209B 176519C718451A04 (fig-forth-auto680):04022 FDB TOGGLE,HERE,ONE,SUB,LIT8
+ 13A7
+20A5 80 (fig-forth-auto680):04023 FCB $80
+20A6 17651AD019E3194C (fig-forth-auto680):04024 FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
+ 1772178A
+ (fig-forth-auto680):04025 * FDB HERE,TWOP,COMMA
+20B2 19C7180219E3 (fig-forth-auto680):04026 FDB HERE,NATP,COMMA
+20B8 1667 (fig-forth-auto680):04027 FDB SEMIS
+ (fig-forth-auto680):04028 *
+ (fig-forth-auto680):04029 * ######>> screen 52 <<
+ (fig-forth-auto680):04030 * ======>> 146 <<
+ (fig-forth-auto680):04031 * ( --- ) P
+ (fig-forth-auto680):04032 * { [COMPILE] name } typical use
+ (fig-forth-auto680):04033 * -DFIND next WORD and COMPILE it, literally;
+ (fig-forth-auto680):04034 * used to compile immediate definitions into words.
+20BA C9 (fig-forth-auto680):04035 FCB $C9 immediate
+20BB 5B434F4D50494C45 (fig-forth-auto680):04036 FCC '[COMPILE' ; '[COMPILE]'
+20C3 DD (fig-forth-auto680):04037 FCB $DD
+20C4 205D (fig-forth-auto680):04038 FDB CREATE-9
+20C6 17B91FAD16A3183D (fig-forth-auto680):04039 BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
+ 1B39172A1AEF19E3
+20D6 1667 (fig-forth-auto680):04040 FDB SEMIS
+ (fig-forth-auto680):04041 *
+ (fig-forth-auto680):04042 * ======>> 147 <<
+ (fig-forth-auto680):04043 * ( n --- ) if compiling. P
+ (fig-forth-auto680):04044 * ( n --- n ) if interpreting.
+ (fig-forth-auto680):04045 * Compile n as a literal, if compiling.
+20D8 C7 (fig-forth-auto680):04046 FCB $C7 immediate
+20D9 4C4954455241 (fig-forth-auto680):04047 FCC 'LITERA' ; 'LITERAL'
+20DF CC (fig-forth-auto680):04048 FCB $CC
+20E0 20BA (fig-forth-auto680):04049 FDB BCOMP-12
+20E2 17B9195817721409 (fig-forth-auto680):04050 LITER FDB DOCOL,STATE,AT,ZBRAN
+20EA 0006 (fig-forth-auto680):04051 FDB LITER2-*-NATWID
+20EC 1BC7139919E3 (fig-forth-auto680):04052 FDB COMPIL,LIT,COMMA
+20F2 1667 (fig-forth-auto680):04053 LITER2 FDB SEMIS
+ (fig-forth-auto680):04054 *
+ (fig-forth-auto680):04055 * ======>> 148 <<
+ (fig-forth-auto680):04056 * ( d --- ) if compiling. P
+ (fig-forth-auto680):04057 * ( d --- d ) if interpreting.
+ (fig-forth-auto680):04058 * Compile d as a double literal, if compiling.
+20F4 C8 (fig-forth-auto680):04059 FCB $C8 immediate
+20F5 444C4954455241 (fig-forth-auto680):04060 FCC 'DLITERA' ; 'DLITERAL'
+20FC CC (fig-forth-auto680):04061 FCB $CC
+20FD 20D8 (fig-forth-auto680):04062 FDB LITER-10
+20FF 17B9195817721409 (fig-forth-auto680):04063 DLITER FDB DOCOL,STATE,AT,ZBRAN
+2107 0006 (fig-forth-auto680):04064 FDB DLITE2-*-NATWID
+2109 173620E220E2 (fig-forth-auto680):04065 FDB SWAP,LITER,LITER ; Just two literals in the right order.
+210F 1667 (fig-forth-auto680):04066 DLITE2 FDB SEMIS
+ (fig-forth-auto680):04067 *
+ (fig-forth-auto680):04068 * ######>> screen 53 <<
+ (fig-forth-auto680):04069 * ======>> 149 <<
+ (fig-forth-auto680):04070 * ( --- )
+ (fig-forth-auto680):04071 * Interpret or compile, according to STATE.
+ (fig-forth-auto680):04072 * Searches words parsed in dictionary first, via -FIND,
+ (fig-forth-auto680):04073 * then checks for valid NUMBER.
+ (fig-forth-auto680):04074 * Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
+ (fig-forth-auto680):04075 * ERROR checks the stack via ?STACK before returning to its caller.
+2111 89 (fig-forth-auto680):04076 FCB $89
+2112 494E544552505245 (fig-forth-auto680):04077 FCC 'INTERPRE' ; 'INTERPRET'
+211A D4 (fig-forth-auto680):04078 FCB $D4
+211B 20F4 (fig-forth-auto680):04079 FDB DLITER-11
+211D 17B9 (fig-forth-auto680):04080 INTERP FDB DOCOL
+211F 1FAD1409 (fig-forth-auto680):04081 INTER2 FDB DFIND,ZBRAN
+2123 001A (fig-forth-auto680):04082 FDB INTER5-*-NATWID
+2125 195817721A1D (fig-forth-auto680):04083 FDB STATE,AT,LESS
+212B 1409 (fig-forth-auto680):04084 FDB ZBRAN
+212D 0008 (fig-forth-auto680):04085 FDB INTER3-*-NATWID
+212F 1AEF19E313FA (fig-forth-auto680):04086 FDB CFA,COMMA,BRAN
+2135 0004 (fig-forth-auto680):04087 FDB INTER4-*-NATWID
+2137 1AEF13EB (fig-forth-auto680):04088 INTER3 FDB CFA,EXEC
+213B 13FA (fig-forth-auto680):04089 INTER4 FDB BRAN
+213D 0018 (fig-forth-auto680):04090 FDB INTER7-*-NATWID
+213F 19C71F57196D1772 (fig-forth-auto680):04091 INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
+ 19AB1409
+214B 0006 (fig-forth-auto680):04092 FDB INTER6-*-NATWID
+214D 20FF13FA (fig-forth-auto680):04093 FDB DLITER,BRAN
+2151 0004 (fig-forth-auto680):04094 FDB INTER7-*-NATWID
+2153 172A20E2 (fig-forth-auto680):04095 INTER6 FDB DROP,LITER
+2157 1D5B13FA (fig-forth-auto680):04096 INTER7 FDB QSTACK,BRAN
+215B FFC2 (fig-forth-auto680):04097 FDB INTER2-*-NATWID
+ (fig-forth-auto680):04098 * FDB SEMIS never executed
+ (fig-forth-auto680):04099
+ (fig-forth-auto680):04100 *
+ (fig-forth-auto680):04101 * ######>> screen 54 <<
+ (fig-forth-auto680):04102 * ======>> 150 <<
+ (fig-forth-auto680):04103 * ( --- )
+ (fig-forth-auto680):04104 * Toggle precedence bit of LATEST definition header.
+ (fig-forth-auto680):04105 * During compiling, most symbols scanned are compiled.
+ (fig-forth-auto680):04106 * IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
+ (fig-forth-auto680):04107 * but may be compiled via ' (TICK).
+215D 89 (fig-forth-auto680):04108 FCB $89
+215E 494D4D4544494154 (fig-forth-auto680):04109 FCC 'IMMEDIAT' ; 'IMMEDIATE'
+2166 C5 (fig-forth-auto680):04110 FCB $C5
+2167 2111 (fig-forth-auto680):04111 FDB INTERP-12
+2169 17B91AD013A7 (fig-forth-auto680):04112 IMMED FDB DOCOL,LATEST,LIT8
+216F 40 (fig-forth-auto680):04113 FCB FIMMED
+2170 1765 (fig-forth-auto680):04114 FDB TOGGLE
+2172 1667 (fig-forth-auto680):04115 FDB SEMIS
+ (fig-forth-auto680):04116 *
+ (fig-forth-auto680):04117 * ======>> 151 <<
+ (fig-forth-auto680):04118 * ( --- ) { VOCABULARY name } input
+ (fig-forth-auto680):04119 * Create a vocabulary entry with a flag for terminating vocabulary searches.
+ (fig-forth-auto680):04120 * Store the current search context in it for linking.
+ (fig-forth-auto680):04121 * At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
+2174 8A (fig-forth-auto680):04122 FCB $8A
+2175 564F434142554C41 (fig-forth-auto680):04123 FCC 'VOCABULAR' ; 'VOCABULARY'
+ 52
+217E D9 (fig-forth-auto680):04124 FCB $D9
+217F 215D (fig-forth-auto680):04125 FDB IMMED-12
+2181 17B91C6A139981A0 (fig-forth-auto680):04126 VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
+ 19E3194C17721AEF
+2191 19E319C718FC1772 (fig-forth-auto680):04127 FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
+ 19E318FC178A1C7A
+ (fig-forth-auto680):04128 * DOVOC FDB TWOP,CONTXT,STORE
+21A1 1802193E178A (fig-forth-auto680):04129 DOVOC FDB NATP,CONTXT,STORE
+21A7 1667 (fig-forth-auto680):04130 FDB SEMIS
+ (fig-forth-auto680):04131 *
+ (fig-forth-auto680):04132 * ======>> 152 <<
+ (fig-forth-auto680):04133 *
+ (fig-forth-auto680):04134 * Note: FORTH does not go here in the rom-able dictionary,
+ (fig-forth-auto680):04135 * since FORTH is a type of variable.
+ (fig-forth-auto680):04136 *
+ (fig-forth-auto680):04137 * (Should make a proper architecture for this at some point.)
+ (fig-forth-auto680):04138 *
+ (fig-forth-auto680):04139 *
+ (fig-forth-auto680):04140 * ======>> 153 <<
+ (fig-forth-auto680):04141 * ( --- )
+ (fig-forth-auto680):04142 * Makes the current interpretation CONTEXT vocabulary
+ (fig-forth-auto680):04143 * also the CURRENT defining vocabulary.
+21A9 8B (fig-forth-auto680):04144 FCB $8B
+21AA 444546494E495449 (fig-forth-auto680):04145 FCC 'DEFINITION' ; 'DEFINITIONS'
+ 4F4E
+21B4 D3 (fig-forth-auto680):04146 FCB $D3
+21B5 2174 (fig-forth-auto680):04147 FDB VOCAB-13
+21B7 17B9193E1772194C (fig-forth-auto680):04148 DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
+ 178A
+21C1 1667 (fig-forth-auto680):04149 FDB SEMIS
+ (fig-forth-auto680):04150 *
+ (fig-forth-auto680):04151 * ======>> 154 <<
+ (fig-forth-auto680):04152 * ( --- )
+ (fig-forth-auto680):04153 * Parse out a comment and toss it away.
+ (fig-forth-auto680):04154 * Leaves the first 32 characters in WORDPAD, which may or may not be useful.
+21C3 C1 (fig-forth-auto680):04155 FCB $C1 immediate (
+21C4 A8 (fig-forth-auto680):04156 FCB $A8
+21C5 21A9 (fig-forth-auto680):04157 FDB DEFIN-14
+21C7 17B913A7 (fig-forth-auto680):04158 PAREN FDB DOCOL,LIT8
+21CB 29 (fig-forth-auto680):04159 FCC ")"
+21CC 1EBC (fig-forth-auto680):04160 FDB WORD
+21CE 1667 (fig-forth-auto680):04161 FDB SEMIS
+ (fig-forth-auto680):04162 *
+ (fig-forth-auto680):04163 * ######>> screen 55 <<
+ (fig-forth-auto680):04164 * ======>> 155 <<
+ (fig-forth-auto680):04165 * ( anything *** nothing )
+ (fig-forth-auto680):04166 * Clear return stack.
+ (fig-forth-auto680):04167 * Then INTERPRET and, if not compiling, prompt with OK,
+ (fig-forth-auto680):04168 * in infinite loop.
+21D0 84 (fig-forth-auto680):04169 FCB $84
+21D1 515549 (fig-forth-auto680):04170 FCC 'QUI' ; 'QUIT'
+21D4 D4 (fig-forth-auto680):04171 FCB $D4
+21D5 21C3 (fig-forth-auto680):04172 FDB PAREN-4
+21D7 17B9183D1906178A (fig-forth-auto680):04173 QUIT FDB DOCOL,ZERO,BLK,STORE
+21DF 1BDD (fig-forth-auto680):04174 FDB LBRAK
+ (fig-forth-auto680):04175 *
+ (fig-forth-auto680):04176 * Here is the outer interpretter
+ (fig-forth-auto680):04177 * which gets a line of input, does it, prints " OK"
+ (fig-forth-auto680):04178 * then repeats :
+21E1 165815771DFF211D (fig-forth-auto680):04179 QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
+ 1958177216A3
+21EF 1409 (fig-forth-auto680):04180 FDB ZBRAN
+21F1 0006 (fig-forth-auto680):04181 FDB QUIT3-*-NATWID
+21F3 1D10 (fig-forth-auto680):04182 FDB PDOTQ
+21F5 03 (fig-forth-auto680):04183 FCB 3
+21F6 204F4B (fig-forth-auto680):04184 FCC ' OK' ; ' OK'
+21F9 13FA (fig-forth-auto680):04185 QUIT3 FDB BRAN
+21FB FFE4 (fig-forth-auto680):04186 FDB QUIT2-*-NATWID
+ (fig-forth-auto680):04187 * FDB SEMIS ( never executed )
+ (fig-forth-auto680):04188 *
+ (fig-forth-auto680):04189 * ======>> 156 <<
+ (fig-forth-auto680):04190 * ( anything --- nothing ) ( anything *** nothing )
+ (fig-forth-auto680):04191 * Clear parameter stack,
+ (fig-forth-auto680):04192 * set STATE to interpret and BASE to DECIMAL,
+ (fig-forth-auto680):04193 * return to input from terminal,
+ (fig-forth-auto680):04194 * restore DRIVE OFFSET to 0,
+ (fig-forth-auto680):04195 * print out "Forth-68",
+ (fig-forth-auto680):04196 * set interpret and define vocabularies to FORTH,
+ (fig-forth-auto680):04197 * and finally, QUIT.
+ (fig-forth-auto680):04198 * Used to force the system to a known state
+ (fig-forth-auto680):04199 * and return control to the initial INTERPRETer.
+21FD 85 (fig-forth-auto680):04200 FCB $85
+21FE 41424F52 (fig-forth-auto680):04201 FCC 'ABOR' ; 'ABORT'
+2202 D4 (fig-forth-auto680):04202 FCB $D4
+2203 21D0 (fig-forth-auto680):04203 FDB QUIT-7
+2205 17B9164D1C251D5B (fig-forth-auto680):04204 ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
+ 242515771D10
+2213 0A (fig-forth-auto680):04205 FCB 10
+2214 466F7274682D3638 (fig-forth-auto680):04206 FCC "Forth-6809"
+ 3039
+221E 2A9D21B7 (fig-forth-auto680):04207 FDB FORTH,DEFIN
+2222 21D7 (fig-forth-auto680):04208 FDB QUIT
+ (fig-forth-auto680):04209 * FDB SEMIS never executed
+ (fig-forth-auto680):04210 PAGE
+ (fig-forth-auto680):04211 *
+ (fig-forth-auto680):04212 * ######>> screen 56 <<
+ (fig-forth-auto680):04213 * bootstrap code... moves rom contents to ram :
+ (fig-forth-auto680):04214 * ======>> 157 <<
+2224 84 (fig-forth-auto680):04215 FCB $84
+2225 434F4C (fig-forth-auto680):04216 FCC 'COL' ; 'COLD'
+2228 C4 (fig-forth-auto680):04217 FCB $C4
+2229 21FD (fig-forth-auto680):04218 FDB ABORT-8
+222B 222D (fig-forth-auto680):04219 COLD FDB *+NATWID
+ (fig-forth-auto680):04220 * Ultimately, we want position indepence,
+ (fig-forth-auto680):04221 * so I'm using PCR where it seems reasonable.
+222D 10EE8DEFE0 (fig-forth-auto680):04222 CENT LDS SINIT,PCR ; Get a useable return stack, at least.
+2232 867C (fig-forth-auto680):04223 LDA #IUPDP ; This is not relative to PC.
+2234 1F8B (fig-forth-auto680):04224 TFR A,DP ; And a useable direct page, too.
+ 7C (fig-forth-auto680):04225 SETDP IUPDP ; (For good measure.)
+ (fig-forth-auto680):04226 *
+ (fig-forth-auto680):04227 * We'll keep this here for the time being.
+ (fig-forth-auto680):04228 * There are better ways to do this, of course.
+ (fig-forth-auto680):04229 * Re-architect, re-architect.
+2236 308D006A (fig-forth-auto680):04230 LEAX RAM,PCR
+223A 9F28 (fig-forth-auto680):04231 STX <XFENCE ; Borrow this variable for a loop terminator.
+223C 318D0890 (fig-forth-auto680):04232 LEAY REND,PCR ; top of destination
+2240 308D00A3 (fig-forth-auto680):04233 LEAX ERAM,PCR ; top of stuff to move
+2244 A682 (fig-forth-auto680):04234 COLD2 LDA ,-X
+2246 A7A2 (fig-forth-auto680):04235 STA ,-Y ; move TASK & FORTH to ram
+2248 9C28 (fig-forth-auto680):04236 CMPX <XFENCE
+224A 26F8 (fig-forth-auto680):04237 BNE COLD2
+ (fig-forth-auto680):04238 *
+ (fig-forth-auto680):04239 * CENT LDS #REND-1 top of destination
+ (fig-forth-auto680):04240 * LDX #ERAM top of stuff to move
+ (fig-forth-auto680):04241 * COLD2 LEAX -1,X ;
+ (fig-forth-auto680):04242 * LDA 0,X
+ (fig-forth-auto680):04243 * PSHS A ; move TASK & FORTH to ram
+ (fig-forth-auto680):04244 * CMPX #RAM
+ (fig-forth-auto680):04245 * BNE COLD2
+ (fig-forth-auto680):04246 *
+ (fig-forth-auto680):04247 * LDS #XFENCE-1 put stack at a safe place for now
+ (fig-forth-auto680):04248 * But that is taken care of.
+ (fig-forth-auto680):04249 * LDX COLINT
+ (fig-forth-auto680):04250 * STX XCOLUM
+224C AE8DEFD2 (fig-forth-auto680):04251 LDX COLINT,PCR
+2250 9F4C (fig-forth-auto680):04252 STX <XCOLUM
+ (fig-forth-auto680):04253 * LDX DELINT
+ (fig-forth-auto680):04254 * STX XDELAY
+2252 AE8DEFCE (fig-forth-auto680):04255 LDX DELINT,PCR
+2256 9F4A (fig-forth-auto680):04256 STX <XDELAY
+ (fig-forth-auto680):04257 * LDX VOCINT
+ (fig-forth-auto680):04258 * STX XVOCL
+2258 AE8DEFC4 (fig-forth-auto680):04259 LDX VOCINT,PCR
+225C 9F2C (fig-forth-auto680):04260 STX <XVOCL
+ (fig-forth-auto680):04261 * LDX DPINIT
+ (fig-forth-auto680):04262 * STX XDICTP
+225E AE8DEFBC (fig-forth-auto680):04263 LDX DPINIT,PCR
+2262 9F2A (fig-forth-auto680):04264 STX <XDICTP
+ (fig-forth-auto680):04265 * LDX FENCIN
+ (fig-forth-auto680):04266 * STX XFENCE
+2264 AE8DEFB4 (fig-forth-auto680):04267 LDX FENCIN,PCR
+2268 9F28 (fig-forth-auto680):04268 STX <XFENCE
+ (fig-forth-auto680):04269 *
+226A 10EE8DEFA3 (fig-forth-auto680):04270 WENT LDS SINIT,PCR ; Get a useable return stack, at least.
+226F 867C (fig-forth-auto680):04271 LDA #IUPDP ; This is not relative to PC.
+2271 1F8B (fig-forth-auto680):04272 TFR A,DP ; And a useable direct page, too.
+ 7C (fig-forth-auto680):04273 SETDP IUPDP ; (For good measure.)
+ (fig-forth-auto680):04274 *
+2273 308DEF9B (fig-forth-auto680):04275 LEAX SINIT,PCR
+2277 3410 (fig-forth-auto680):04276 PSHS X ; for loop termination
+2279 5F (fig-forth-auto680):04277 CLRB ; Yes, I'm being a little ridiculous. Only a little.
+227A 1F02 (fig-forth-auto680):04278 TFR D,Y
+227C 31A828 (fig-forth-auto680):04279 LEAY XFENCE-UORIG,Y ; top of destination
+227F 308DEF99 (fig-forth-auto680):04280 LEAX FENCIN,PCR ; top of stuff to move
+2283 EC83 (fig-forth-auto680):04281 WARM2 LDD ,--X ; All entries are 16 bit.
+2285 EDA3 (fig-forth-auto680):04282 STD ,--Y
+2287 ACE4 (fig-forth-auto680):04283 CMPX ,S
+2289 26F8 (fig-forth-auto680):04284 BNE WARM2
+228B 3262 (fig-forth-auto680):04285 LEAS 2,S ; But we'll reset the return stack shortly, anyway.
+ (fig-forth-auto680):04286 * WENT LDS #XFENCE-1 top of destination
+ (fig-forth-auto680):04287 * LDX #FENCIN top of stuff to move
+ (fig-forth-auto680):04288 * WARM2 LEAX -1,X ;
+ (fig-forth-auto680):04289 * LDA 0,X
+ (fig-forth-auto680):04290 * PSHS A ;
+ (fig-forth-auto680):04291 * CMPX #SINIT
+ (fig-forth-auto680):04292 * BNE WARM2
+ (fig-forth-auto680):04293 *
+ (fig-forth-auto680):04294 * LDS SINIT
+ (fig-forth-auto680):04295 * S is already there.
+ (fig-forth-auto680):04296 * LDX UPINIT
+ (fig-forth-auto680):04297 * STX UP init user ram pointer
+ (fig-forth-auto680):04298 * UP is already there (DP).
+ (fig-forth-auto680):04299 * LDX #ABORT
+ (fig-forth-auto680):04300 * STX IP
+228D 318DFF76 (fig-forth-auto680):04301 LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
+ (fig-forth-auto680):04302 *
+2291 12 (fig-forth-auto680):04303 NOP Here is a place to jump to special user
+2292 12 (fig-forth-auto680):04304 NOP initializations such as I/0 interrups
+2293 12 (fig-forth-auto680):04305 NOP
+ (fig-forth-auto680):04306 *
+ (fig-forth-auto680):04307 * For systems with TRACE:
+2294 8E0000 (fig-forth-auto680):04308 LDX #00
+ (fig-forth-auto680):04309 * STX TRLIM clear trace mode
+2297 9F0A (fig-forth-auto680):04310 STX <TRLIM clear trace mode (both bytes)
+2299 8E0000 (fig-forth-auto680):04311 LDX #0
+ (fig-forth-auto680):04312 * STX BRKPT clear breakpoint address
+229C 9F0C (fig-forth-auto680):04313 STX <BRKPT clear breakpoint address
+ (fig-forth-auto680):04314 * JMP RPSTOR+2 start the virtual machine running !
+229E 17F3B9 (fig-forth-auto680):04315 LBSR RPSTOR+NATWID start the virtual machine running !
+22A1 16EF84 (fig-forth-auto680):04316 LBRA NEXT ; But we must also give RP! someplace to return.
+ (fig-forth-auto680):04317 * RP! sets up the return stack pointer, then Y references abort.
+ (fig-forth-auto680):04318 *
+ (fig-forth-auto680):04319 * Here is the stuff that gets copied to ram :
+ (fig-forth-auto680):04320 * (not * at address $140:)
+ (fig-forth-auto680):04321 * at an appropriate address:
+ (fig-forth-auto680):04322 *
+22A4 3000300000000000 (fig-forth-auto680):04323 RAM FDB $3000,$3000,0,0
+ (fig-forth-auto680):04324
+ (fig-forth-auto680):04325 * ======>> (152) <<
+ (fig-forth-auto680):04326 * ( --- ) P
+ (fig-forth-auto680):04327 * Makes FORTH the current interpretation vocabulary.
+ (fig-forth-auto680):04328 * In order to make this ROMmable, this entry is set up as the tail-end,
+ (fig-forth-auto680):04329 * and copied to RAM in the start-up code.
+ (fig-forth-auto680):04330 * We want a more elegant solution to this, too. Greedy, maybe.
+22AC C5 (fig-forth-auto680):04331 FCB $C5 immediate
+22AD 464F5254 (fig-forth-auto680):04332 FCC 'FORT' ; 'FORTH'
+22B1 C8 (fig-forth-auto680):04333 FCB $C8
+22B2 2A7C (fig-forth-auto680):04334 FDB NOOP-7 ; Note that this does not link to COLD!
+22B4 1C8621A181A02AC5 (fig-forth-auto680):04335 RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
+22BC 0000 (fig-forth-auto680):04336 FDB 0
+22BE 28432920466F7274 (fig-forth-auto680):04337 FCC "(C) Forth Interest Group, 1979"
+ 6820496E74657265
+ 73742047726F7570
+ 2C2031393739
+22DC 84 (fig-forth-auto680):04338 FCB $84
+22DD 544153 (fig-forth-auto680):04339 FCC 'TAS' ; 'TASK'
+22E0 CB (fig-forth-auto680):04340 FCB $CB
+22E1 2A95 (fig-forth-auto680):04341 FDB FORTH-8
+22E3 17B91667 (fig-forth-auto680):04342 RTASK FDB DOCOL,SEMIS
+22E7 4461766964204C69 (fig-forth-auto680):04343 ERAM FCC "David Lion"
+ 6F6E
+ (fig-forth-auto680):04344 PAGE
+ (fig-forth-auto680):04345 *
+ (fig-forth-auto680):04346 * ######>> screen 57 <<
+ (fig-forth-auto680):04347 * ======>> 158 <<
+ (fig-forth-auto680):04348 * ( n0 --- d0 )
+ (fig-forth-auto680):04349 * Sign extend n0 to a double integer.
+22F1 84 (fig-forth-auto680):04350 FCB $84
+22F2 532D3E (fig-forth-auto680):04351 FCC 'S->' ; 'S->D'
+22F5 C4 (fig-forth-auto680):04352 FCB $C4
+22F6 2224 (fig-forth-auto680):04353 FDB COLD-7 ; Note that this does not link to FORTH (RFORTH)!
+22F8 17B9174516B516EF (fig-forth-auto680):04354 STOD FDB DOCOL,DUP,ZLESS,MINUS
+2300 1667 (fig-forth-auto680):04355 FDB SEMIS
+ (fig-forth-auto680):04356
+ (fig-forth-auto680):04357
+ (fig-forth-auto680):04358 *
+ (fig-forth-auto680):04359 * ======>> 159 <<
+ (fig-forth-auto680):04360 * ( multiplier multiplicand --- product )
+ (fig-forth-auto680):04361 * Signed word multiply.
+2302 81 (fig-forth-auto680):04362 FCB $81 ; *
+2303 AA (fig-forth-auto680):04363 FCB $AA
+2304 22F1 (fig-forth-auto680):04364 FDB STOD-7
+2306 2308 (fig-forth-auto680):04365 STAR FDB *+NATWID
+2308 17F29C (fig-forth-auto680):04366 LBSR USTAR+NATWID ; or [USTAR,PCR]?
+230B 3342 (fig-forth-auto680):04367 LEAU NATWID,U ; Drop high word.
+230D 39 (fig-forth-auto680):04368 RTS
+ (fig-forth-auto680):04369 * JSR USTARS
+ (fig-forth-auto680):04370 * LEAS 1,S ;
+ (fig-forth-auto680):04371 * LEAS 1,S ;
+ (fig-forth-auto680):04372 * JMP NEXT
+ (fig-forth-auto680):04373 *
+ (fig-forth-auto680):04374 * ======>> 160 <<
+ (fig-forth-auto680):04375 * ( dividend divisor --- remainder quotient )
+ (fig-forth-auto680):04376 * M/ in word-only form, i. e., signed division of 2nd word by top word,
+ (fig-forth-auto680):04377 * yielding signed word quotient and remainder.
+230E 84 (fig-forth-auto680):04378 FCB $84
+230F 2F4D4F (fig-forth-auto680):04379 FCC '/MO' ; '/MOD'
+2312 C4 (fig-forth-auto680):04380 FCB $C4
+2313 2302 (fig-forth-auto680):04381 FDB STAR-4
+2315 17B9168122F81690 (fig-forth-auto680):04382 SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
+ 15DB
+231F 1667 (fig-forth-auto680):04383 FDB SEMIS
+ (fig-forth-auto680):04384 *
+ (fig-forth-auto680):04385 * ======>> 161 <<
+ (fig-forth-auto680):04386 * ( dividend divisor --- quotient )
+ (fig-forth-auto680):04387 * Signed word divide without remainder.
+2321 81 (fig-forth-auto680):04388 FCB $81 ; /
+2322 AF (fig-forth-auto680):04389 FCB $AF
+2323 230E (fig-forth-auto680):04390 FDB SLMOD-7
+2325 17B923151736172A (fig-forth-auto680):04391 SLASH FDB DOCOL,SLMOD,SWAP,DROP
+232D 1667 (fig-forth-auto680):04392 FDB SEMIS
+ (fig-forth-auto680):04393 *
+ (fig-forth-auto680):04394 * ======>> 162 <<
+ (fig-forth-auto680):04395 * ( dividend divisor --- remainder )
+ (fig-forth-auto680):04396 * Remainder function, result takes sign of dividend.
+232F 83 (fig-forth-auto680):04397 FCB $83
+2330 4D4F (fig-forth-auto680):04398 FCC 'MO' ; 'MOD'
+2332 C4 (fig-forth-auto680):04399 FCB $C4
+2333 2321 (fig-forth-auto680):04400 FDB SLASH-4
+2335 17B92315172A (fig-forth-auto680):04401 MOD FDB DOCOL,SLMOD,DROP
+233B 1667 (fig-forth-auto680):04402 FDB SEMIS
+ (fig-forth-auto680):04403 *
+ (fig-forth-auto680):04404 * ======>> 163 <<
+ (fig-forth-auto680):04405 * ( multiplier multiplicand divisor --- remainder quotient )
+ (fig-forth-auto680):04406 * Signed precise division of product:
+ (fig-forth-auto680):04407 * multiply 2nd and 3rd words on stack
+ (fig-forth-auto680):04408 * and divide the 31-bit product by the top word,
+ (fig-forth-auto680):04409 * leaving both quotient and remainder.
+ (fig-forth-auto680):04410 * Remainder takes sign of product.
+ (fig-forth-auto680):04411 * Guaranteed not to lose significant bits in 16 bit integer math.
+233D 85 (fig-forth-auto680):04412 FCB $85
+233E 2A2F4D4F (fig-forth-auto680):04413 FCC '*/MO' ; '*/MOD'
+2342 C4 (fig-forth-auto680):04414 FCB $C4
+2343 232F (fig-forth-auto680):04415 FDB MOD-6
+2345 17B9168115A51690 (fig-forth-auto680):04416 SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
+ 15DB
+234F 1667 (fig-forth-auto680):04417 FDB SEMIS
+ (fig-forth-auto680):04418 *
+ (fig-forth-auto680):04419 * ======>> 164 <<
+ (fig-forth-auto680):04420 * ( multiplier multiplicand divisor --- quotient )
+ (fig-forth-auto680):04421 * */MOD without remainder.
+2351 82 (fig-forth-auto680):04422 FCB $82
+2352 2A (fig-forth-auto680):04423 FCC '*' ; '*/'
+2353 AF (fig-forth-auto680):04424 FCB $AF
+2354 233D (fig-forth-auto680):04425 FDB SSMOD-8
+2356 17B923451736172A (fig-forth-auto680):04426 SSLASH FDB DOCOL,SSMOD,SWAP,DROP
+235E 1667 (fig-forth-auto680):04427 FDB SEMIS
+ (fig-forth-auto680):04428 *
+ (fig-forth-auto680):04429 * ======>> 165 <<
+ (fig-forth-auto680):04430 * ( ud1 u1 --- u2 ud2 )
+ (fig-forth-auto680):04431 * U/ with an (unsigned) double quotient.
+ (fig-forth-auto680):04432 * Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
+ (fig-forth-auto680):04433 * if you are prepared to deal with the extra 16 bits of result.
+2360 85 (fig-forth-auto680):04434 FCB $85
+2361 4D2F4D4F (fig-forth-auto680):04435 FCC 'M/MO' ; 'M/MOD'
+2365 C4 (fig-forth-auto680):04436 FCB $C4
+2366 2351 (fig-forth-auto680):04437 FDB SSLASH-5
+2368 17B91681183D169C (fig-forth-auto680):04438 MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
+ 15DB
+2372 16901736168115DB (fig-forth-auto680):04439 FDB FROMR,SWAP,TOR,USLASH,FROMR
+ 1690
+237C 1667 (fig-forth-auto680):04440 FDB SEMIS
+ (fig-forth-auto680):04441 *
+ (fig-forth-auto680):04442 * ======>> 166 <<
+ (fig-forth-auto680):04443 * ( n>=0 --- n )
+ (fig-forth-auto680):04444 * ( n<0 --- -n )
+ (fig-forth-auto680):04445 * Convert the top of stack to its absolute value.
+237E 83 (fig-forth-auto680):04446 FCB $83
+237F 4142 (fig-forth-auto680):04447 FCC 'AB' ; 'ABS'
+2381 D3 (fig-forth-auto680):04448 FCB $D3
+2382 2360 (fig-forth-auto680):04449 FDB MSMOD-8
+2384 17B9174516B51409 (fig-forth-auto680):04450 ABS FDB DOCOL,DUP,ZLESS,ZBRAN
+238C 0002 (fig-forth-auto680):04451 FDB ABS2-*-NATWID
+238E 16EF (fig-forth-auto680):04452 FDB MINUS
+2390 1667 (fig-forth-auto680):04453 ABS2 FDB SEMIS
+ (fig-forth-auto680):04454 *
+ (fig-forth-auto680):04455 * ======>> 167 <<
+ (fig-forth-auto680):04456 * ( d>=0 --- d )
+ (fig-forth-auto680):04457 * ( d<0 --- -d )
+ (fig-forth-auto680):04458 * Convert the top double to its absolute value.
+2392 84 (fig-forth-auto680):04459 FCB $84
+2393 444142 (fig-forth-auto680):04460 FCC 'DAB' ; 'DABS'
+2396 D3 (fig-forth-auto680):04461 FCB $D3
+2397 237E (fig-forth-auto680):04462 FDB ABS-6
+2399 17B9174516B51409 (fig-forth-auto680):04463 DABS FDB DOCOL,DUP,ZLESS,ZBRAN
+23A1 0002 (fig-forth-auto680):04464 FDB DABS2-*-NATWID
+23A3 1702 (fig-forth-auto680):04465 FDB DMINUS
+23A5 1667 (fig-forth-auto680):04466 DABS2 FDB SEMIS
+ (fig-forth-auto680):04467 *
+ (fig-forth-auto680):04468 * ######>> screen 58 <<
+ (fig-forth-auto680):04469 * Disc primitives :
+ (fig-forth-auto680):04470 * ======>> 168 <<
+ (fig-forth-auto680):04471 * ( --- vadr )
+ (fig-forth-auto680):04472 * Least Recently Used buffer.
+ (fig-forth-auto680):04473 * Really should be with FIRST and LIMIT in the per-task table.
+23A7 83 (fig-forth-auto680):04474 FCB $83
+23A8 5553 (fig-forth-auto680):04475 FCC 'US' ; 'USE'
+23AA C5 (fig-forth-auto680):04476 FCB $C5
+23AB 2392 (fig-forth-auto680):04477 FDB DABS-7
+23AD 17E9 (fig-forth-auto680):04478 USE FDB DOCON
+23AF 7C58 (fig-forth-auto680):04479 FDB XUSE
+ (fig-forth-auto680):04480 * ======>> 169 <<
+ (fig-forth-auto680):04481 * ( --- vadr )
+ (fig-forth-auto680):04482 * Most Recently Used buffer.
+ (fig-forth-auto680):04483 * Really should be with FIRST and LIMIT in the per-task table.
+23B1 84 (fig-forth-auto680):04484 FCB $84
+23B2 505245 (fig-forth-auto680):04485 FCC 'PRE' ; 'PREV'
+23B5 D6 (fig-forth-auto680):04486 FCB $D6
+23B6 23A7 (fig-forth-auto680):04487 FDB USE-6
+23B8 17E9 (fig-forth-auto680):04488 PREV FDB DOCON
+23BA 7C5A (fig-forth-auto680):04489 FDB XPREV
+ (fig-forth-auto680):04490 * ======>> 170 <<
+ (fig-forth-auto680):04491 * ( buffer1 --- buffer2 f )
+ (fig-forth-auto680):04492 * Bump to next buffer,
+ (fig-forth-auto680):04493 * flag false if result is PREVious buffer,
+ (fig-forth-auto680):04494 * otherwise flag true.
+ (fig-forth-auto680):04495 * Used in the LRU allocation routines.
+23BC 84 (fig-forth-auto680):04496 FCB $84
+23BD 2B4255 (fig-forth-auto680):04497 FCC '+BU' ; '+BUF'
+23C0 C6 (fig-forth-auto680):04498 FCB $C6
+23C1 23B1 (fig-forth-auto680):04499 FDB PREV-7
+23C3 17B913A7 (fig-forth-auto680):04500 PBUF FDB DOCOL,LIT8
+23C7 84 (fig-forth-auto680):04501 FCB $84
+23C8 16C6174518761A11 (fig-forth-auto680):04502 FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
+ 1409
+23D2 0004 (fig-forth-auto680):04503 FDB PBUF2-*-NATWID
+23D4 172A186A (fig-forth-auto680):04504 FDB DROP,FIRST
+23D8 174523B817721A04 (fig-forth-auto680):04505 PBUF2 FDB DUP,PREV,AT,SUB
+23E0 1667 (fig-forth-auto680):04506 FDB SEMIS
+ (fig-forth-auto680):04507 *
+ (fig-forth-auto680):04508 * ======>> 171 <<
+ (fig-forth-auto680):04509 * ( --- )
+ (fig-forth-auto680):04510 * Mark PREVious buffer dirty, in need of being written out.
+23E2 86 (fig-forth-auto680):04511 FCB $86
+23E3 5550444154 (fig-forth-auto680):04512 FCC 'UPDAT' ; 'UPDATE'
+23E8 C5 (fig-forth-auto680):04513 FCB $C5
+23E9 23BC (fig-forth-auto680):04514 FDB PBUF-7
+23EB 17B923B817721772 (fig-forth-auto680):04515 UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
+ 13998000161E23B8
+ 1772178A
+23FF 1667 (fig-forth-auto680):04516 FDB SEMIS
+ (fig-forth-auto680):04517 *
+ (fig-forth-auto680):04518 * ======>> 172 <<
+ (fig-forth-auto680):04519 * ( --- )
+ (fig-forth-auto680):04520 * Mark all buffers empty.
+ (fig-forth-auto680):04521 * Standard method of discarding changes.
+2401 8D (fig-forth-auto680):04522 FCB $8D
+2402 454D5054592D4255 (fig-forth-auto680):04523 FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
+ 46464552
+240E D3 (fig-forth-auto680):04524 FCB $D3
+240F 23E2 (fig-forth-auto680):04525 FDB UPDATE-9
+2411 17B9186A1876171C (fig-forth-auto680):04526 MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
+ 1A041E72
+241D 1667 (fig-forth-auto680):04527 FDB SEMIS
+ (fig-forth-auto680):04528 *
+ (fig-forth-auto680):04529 * ======>> 173 <<
+ (fig-forth-auto680):04530 * ( --- )
+ (fig-forth-auto680):04531 * Clear the current offset to the block numbers in the drive interface.
+ (fig-forth-auto680):04532 * The drives need to be re-architected.
+ (fig-forth-auto680):04533 * Would be cool to have RAM and ROM drives supported
+ (fig-forth-auto680):04534 * in addition to regular physical persistent store.
+241F 83 (fig-forth-auto680):04535 FCB $83
+2420 4452 (fig-forth-auto680):04536 FCC 'DR' ; 'DR0'
+2422 B0 (fig-forth-auto680):04537 FCB $B0
+2423 2401 (fig-forth-auto680):04538 FDB MTBUF-16
+2425 17B9183D1930178A (fig-forth-auto680):04539 DRZERO FDB DOCOL,ZERO,OFSET,STORE
+242D 1667 (fig-forth-auto680):04540 FDB SEMIS
+ (fig-forth-auto680):04541 *
+ (fig-forth-auto680):04542 * ======>> 174 <<== system dependant word
+ (fig-forth-auto680):04543 * ( --- )
+ (fig-forth-auto680):04544 * Set the current offset in the drive interface to reference the second drive.
+ (fig-forth-auto680):04545 * The hard-coded number in there needs to be in a table.
+242F 83 (fig-forth-auto680):04546 FCB $83
+2430 4452 (fig-forth-auto680):04547 FCC 'DR' ; 'DR1'
+2432 B1 (fig-forth-auto680):04548 FCB $B1
+2433 241F (fig-forth-auto680):04549 FDB DRZERO-6
+2435 17B9139907D01930 (fig-forth-auto680):04550 DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
+ 178A
+243F 1667 (fig-forth-auto680):04551 FDB SEMIS
+ (fig-forth-auto680):04552 *
+ (fig-forth-auto680):04553 * ######>> screen 59 <<
+ (fig-forth-auto680):04554 * ======>> 175 <<
+ (fig-forth-auto680):04555 * ( n --- buffer )
+ (fig-forth-auto680):04556 * Get a free buffer,
+ (fig-forth-auto680):04557 * assign it to block n,
+ (fig-forth-auto680):04558 * return buffer address.
+ (fig-forth-auto680):04559 * Will free a buffer by writing it, if necessary.
+ (fig-forth-auto680):04560 * Does not actually read the block.
+ (fig-forth-auto680):04561 * A bug in the fig LRU algorithm, which I have not fixed,
+ (fig-forth-auto680):04562 * gives the PREVious buffer if USE gets set to PREVious.
+ (fig-forth-auto680):04563 * (The bug is that USE sometimes gets set to PREVious.)
+ (fig-forth-auto680):04564 * This bug sometimes causes sector moves to become sector fills.
+2441 86 (fig-forth-auto680):04565 FCB $86
+2442 4255464645 (fig-forth-auto680):04566 FCC 'BUFFE' ; 'BUFFER'
+2447 D2 (fig-forth-auto680):04567 FCB $D2
+2448 242F (fig-forth-auto680):04568 FDB DRONE-6
+244A 17B923AD17721745 (fig-forth-auto680):04569 BUFFER FDB DOCOL,USE,AT,DUP,TOR
+ 1681
+2454 23C31409 (fig-forth-auto680):04570 BUFFR2 FDB PBUF,ZBRAN
+2458 FFFA (fig-forth-auto680):04571 FDB BUFFR2-*-NATWID
+245A 23AD178A169C1772 (fig-forth-auto680):04572 FDB USE,STORE,R,AT,ZLESS
+ 16B5
+2464 1409 (fig-forth-auto680):04573 FDB ZBRAN
+2466 0012 (fig-forth-auto680):04574 FDB BUFFR3-*-NATWID
+ (fig-forth-auto680):04575 * FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
+2468 169C1802169C1772 (fig-forth-auto680):04576 FDB R,NATP,R,AT,LIT,$7FFF,AND,ZERO,RW
+ 13997FFF160E183D
+ 263B
+ (fig-forth-auto680):04577 * BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
+247A 169C178A169C23B8 (fig-forth-auto680):04578 BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
+ 178A16901802
+2488 1667 (fig-forth-auto680):04579 FDB SEMIS
+ (fig-forth-auto680):04580 *
+ (fig-forth-auto680):04581 * ######>> screen 60 <<
+ (fig-forth-auto680):04582 * ======>> 176 <<
+ (fig-forth-auto680):04583 * ( n --- buffer )
+ (fig-forth-auto680):04584 * Get BUFFER containing block n, relative to OFFSET.
+ (fig-forth-auto680):04585 * If block n is not in a buffer, bring it in.
+ (fig-forth-auto680):04586 * Returns buffer address.
+248A 85 (fig-forth-auto680):04587 FCB $85
+248B 424C4F43 (fig-forth-auto680):04588 FCC 'BLOC' ; 'BLOCK'
+248F CB (fig-forth-auto680):04589 FCB $CB
+2490 2441 (fig-forth-auto680):04590 FDB BUFFER-9
+2492 17B91930177216C6 (fig-forth-auto680):04591 BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
+ 1681
+249C 23B8177217451772 (fig-forth-auto680):04592 FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
+ 169C1A04174516C6
+ 1409
+24AE 0032 (fig-forth-auto680):04593 FDB BLOCK5-*-NATWID
+24B0 23C316A31409 (fig-forth-auto680):04594 BLOCK3 FDB PBUF,ZEQU,ZBRAN
+24B6 0012 (fig-forth-auto680):04595 FDB BLOCK4-*-NATWID
+ (fig-forth-auto680):04596 * FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
+24B8 172A169C244A1745 (fig-forth-auto680):04597 FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
+ 169C1845263B17F7
+ 1A04
+24CA 17451772169C1A04 (fig-forth-auto680):04598 BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
+ 174516C616A31409
+24DA FFD4 (fig-forth-auto680):04599 FDB BLOCK3-*-NATWID
+24DC 174523B8178A (fig-forth-auto680):04600 FDB DUP,PREV,STORE
+ (fig-forth-auto680):04601 * BLOCK5 FDB FROMR,DROP,TWOP
+24E2 1690172A1802 (fig-forth-auto680):04602 BLOCK5 FDB FROMR,DROP,NATP
+24E8 1667 (fig-forth-auto680):04603 FDB SEMIS
+ (fig-forth-auto680):04604 *
+ (fig-forth-auto680):04605 * ######>> screen 61 <<
+ (fig-forth-auto680):04606 * ======>> 177 <<
+ (fig-forth-auto680):04607 * ( line screen --- buffer C/L)
+ (fig-forth-auto680):04608 * Bring in the sector containing the specified line of the specified screen.
+ (fig-forth-auto680):04609 * Returns the buffer address and the width of the screen.
+ (fig-forth-auto680):04610 * Screen number is relative to OFFSET.
+ (fig-forth-auto680):04611 * The line number may be beyond screen 4,
+ (fig-forth-auto680):04612 * (LINE) will get the appropriate screen.
+24EA 86 (fig-forth-auto680):04613 FCB $86
+24EB 284C494E45 (fig-forth-auto680):04614 FCC '(LINE' ; '(LINE)'
+24F0 A9 (fig-forth-auto680):04615 FCB $A9
+24F1 248A (fig-forth-auto680):04616 FDB BLOCK-8
+24F3 17B9168113A7 (fig-forth-auto680):04617 PLINE FDB DOCOL,TOR,LIT8
+24F9 40 (fig-forth-auto680):04618 FCB $40
+24FA 188223451690188E (fig-forth-auto680):04619 FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
+ 230616C6249216C6
+ 13A7
+250C 40 (fig-forth-auto680):04620 FCB $40
+250D 1667 (fig-forth-auto680):04621 FDB SEMIS
+ (fig-forth-auto680):04622 *
+ (fig-forth-auto680):04623 * ======>> 178 <<
+ (fig-forth-auto680):04624 * ( line screen --- )
+ (fig-forth-auto680):04625 * Print the line of the screen as found by (LINE), suppress trailing BLANKS.
+250F 85 (fig-forth-auto680):04626 FCB $85
+2510 2E4C494E (fig-forth-auto680):04627 FCC '.LIN' ; '.LINE'
+2514 C5 (fig-forth-auto680):04628 FCB $C5
+2515 24EA (fig-forth-auto680):04629 FDB PLINE-9
+2517 17B924F31CDD1CAF (fig-forth-auto680):04630 DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
+251F 1667 (fig-forth-auto680):04631 FDB SEMIS
+ (fig-forth-auto680):04632 *
+ (fig-forth-auto680):04633 * ======>> 179 <<
+ (fig-forth-auto680):04634 * ( n --- )
+ (fig-forth-auto680):04635 * If WARNING is 0, print "MESSAGE #n";
+ (fig-forth-auto680):04636 * otherwise, print line n relative to screen 4,
+ (fig-forth-auto680):04637 * the line number may be negative.
+ (fig-forth-auto680):04638 * Uses .LINE, but counter-adjusts to be relative to the real drive 0.
+2521 87 (fig-forth-auto680):04639 FCB $87
+2522 4D4553534147 (fig-forth-auto680):04640 FCC 'MESSAG' ; 'MESSAGE'
+2528 C5 (fig-forth-auto680):04641 FCB $C5
+2529 250F (fig-forth-auto680):04642 FDB DLINE-8
+252B 17B918D817721409 (fig-forth-auto680):04643 MESS FDB DOCOL,WARN,AT,ZBRAN
+2533 0019 (fig-forth-auto680):04644 FDB MESS3-*-NATWID
+2535 1A8A1409 (fig-forth-auto680):04645 FDB DDUP,ZBRAN
+2539 0013 (fig-forth-auto680):04646 FDB MESS3-*-NATWID
+253B 13A7 (fig-forth-auto680):04647 FDB LIT8
+253D 04 (fig-forth-auto680):04648 FCB 4
+253E 19301772188E2325 (fig-forth-auto680):04649 FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
+ 1A04251713FA
+254C 000B (fig-forth-auto680):04650 FDB MESS4-*-NATWID
+254E 1D10 (fig-forth-auto680):04651 MESS3 FDB PDOTQ
+2550 06 (fig-forth-auto680):04652 FCB 6
+2551 657272202320 (fig-forth-auto680):04653 FCC 'err # ' ; 'err # '
+2557 28D6 (fig-forth-auto680):04654 FDB DOT
+2559 1667 (fig-forth-auto680):04655 MESS4 FDB SEMIS
+ (fig-forth-auto680):04656 *
+ (fig-forth-auto680):04657 * ======>> 180 <<
+ (fig-forth-auto680):04658 * ( n --- )
+ (fig-forth-auto680):04659 * Begin interpretation of screen (block) n.
+ (fig-forth-auto680):04660 * See also ARROW, SEMIS, and NULL.
+255B 84 (fig-forth-auto680):04661 FCB $84
+255C 4C4F41 (fig-forth-auto680):04662 FCC 'LOA' ; 'LOAD' : input:scr #
+255F C4 (fig-forth-auto680):04663 FCB $C4
+2560 2521 (fig-forth-auto680):04664 FDB MESS-10
+2562 17B9190617721681 (fig-forth-auto680):04665 LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
+ 190F17721681183D
+ 190F178A
+2576 188E23061906178A (fig-forth-auto680):04666 FDB BSCR,STAR,BLK,STORE
+257E 211D1690190F178A (fig-forth-auto680):04667 FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
+ 16901906178A
+258C 1667 (fig-forth-auto680):04668 FDB SEMIS
+ (fig-forth-auto680):04669 *
+ (fig-forth-auto680):04670 * ======>> 181 <<
+ (fig-forth-auto680):04671 * ( --- ) P
+ (fig-forth-auto680):04672 * Continue interpreting source code on the next screen.
+258E C3 (fig-forth-auto680):04673 FCB $C3
+258F 2D2D (fig-forth-auto680):04674 FCC '--' ; '-->'
+2591 BE (fig-forth-auto680):04675 FCB $BE
+2592 255B (fig-forth-auto680):04676 FDB LOAD-7
+2594 17B91BAE183D190F (fig-forth-auto680):04677 ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
+ 178A188E
+25A0 19061772171C2335 (fig-forth-auto680):04678 FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
+ 1A0419061751
+25AE 1667 (fig-forth-auto680):04679 FDB SEMIS
+ (fig-forth-auto680):04680 PAGE
+ (fig-forth-auto680):04681 *
+ (fig-forth-auto680):04682 *
+ (fig-forth-auto680):04683 * ######>> screen 63 <<
+ (fig-forth-auto680):04684 * The next 4 subroutines are machine dependent, and are
+ (fig-forth-auto680):04685 * called by words 13 through 16 in the dictionary.
+ (fig-forth-auto680):04686 *
+ (fig-forth-auto680):04687 * ======>> 182 << code for EMIT
+ (fig-forth-auto680):04688 * ( --- ) No parameter stack effect.
+ (fig-forth-auto680):04689 * Interfaces directly with ROM. Expects output character in D (therefore, B).
+ (fig-forth-auto680):04690 * Output using rom CHROUT: redirectable to a printer on Coco.
+ (fig-forth-auto680):04691 * Outputs the character on stack (low byte of 1 bit word/cell).
+25B0 3468 (fig-forth-auto680):04692 PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.)
+25B2 1F98 (fig-forth-auto680):04693 TFR B,A ; Coco ROM wants it in A.
+25B4 5F (fig-forth-auto680):04694 CLRB
+25B5 1F9B (fig-forth-auto680):04695 TFR B,DP ; Give the ROM its direct page.
+25B7 AD9FA002 (fig-forth-auto680):04696 JSR [$A002] ; Output the character in A.
+25BB 35E8 (fig-forth-auto680):04697 PULS Y,U,DP,PC
+ (fig-forth-auto680):04698 * PEMIT STB N save B
+ (fig-forth-auto680):04699 * STX N+1 save X
+ (fig-forth-auto680):04700 * LDB ACIAC
+ (fig-forth-auto680):04701 * BITB #2 check ready bit
+ (fig-forth-auto680):04702 * BEQ PEMIT+4 if not ready for more data
+ (fig-forth-auto680):04703 * STA ACIAD
+ (fig-forth-auto680):04704 * LDX UP
+ (fig-forth-auto680):04705 * STB IOSTAT-UORIG,X
+ (fig-forth-auto680):04706 * LDB N recover B & X
+ (fig-forth-auto680):04707 * LDX N+1
+ (fig-forth-auto680):04708 * RTS only A register may change
+ (fig-forth-auto680):04709 * PEMIT JMP $E1D1 for MIKBUG
+ (fig-forth-auto680):04710 * PEMIT FCB $3F,$11,$39 for PROTO
+ (fig-forth-auto680):04711 * PEMIT JMP $D286 for Smoke Signal DOS
+ (fig-forth-auto680):04712 *
+ (fig-forth-auto680):04713 * ======>> 183 << code for KEY
+ (fig-forth-auto680):04714 * ( --- ) No parameter stack effect.
+ (fig-forth-auto680):04715 * Returns character or break flag in D, since this interfaces with Coco ROM.
+ (fig-forth-auto680):04716 * Wait for key from POLCAT on Coco.
+ (fig-forth-auto680):04717 * Returns the character code for the key pressed.
+25BD 3468 (fig-forth-auto680):04718 PKEY PSHS Y,U,DP ; Must save everything important for this one.
+25BF 86CF (fig-forth-auto680):04719 LDA #$CF ; a cursor of sorts
+25C1 5F (fig-forth-auto680):04720 CLRB
+25C2 1F9B (fig-forth-auto680):04721 TFR B,DP
+ 00 (fig-forth-auto680):04722 SETDP 0
+25C4 9E88 (fig-forth-auto680):04723 LDX <$88 ; location
+25C6 E684 (fig-forth-auto680):04724 LDB ,X ; save glyph
+25C8 A784 (fig-forth-auto680):04725 STA ,X
+25CA AD9FA000 (fig-forth-auto680):04726 PKEYLP JSR [$A000]
+25CE B7041A (fig-forth-auto680):04727 STA $41A ; DBG!
+25D1 27F7 (fig-forth-auto680):04728 BEQ PKEYLP
+25D3 FD0418 (fig-forth-auto680):04729 STD $418 ; DBG!
+25D6 E784 (fig-forth-auto680):04730 STB ,X ; restore
+25D8 5F (fig-forth-auto680):04731 PKEYR CLRB ; for the break flag, shares code with PQTER
+25D9 8103 (fig-forth-auto680):04732 CMPA #3 ; break key
+25DB 2601 (fig-forth-auto680):04733 BNE PKEYGT
+25DD 53 (fig-forth-auto680):04734 COMB ; for the break flag
+25DE 1E89 (fig-forth-auto680):04735 PKEYGT EXG A,B ; Leave it in D for return.
+25E0 35E8 (fig-forth-auto680):04736 PULS Y,U,DP,PC ; Shares exit with PQTER
+ 7C (fig-forth-auto680):04737 SETDP IUPDP
+ (fig-forth-auto680):04738 * PKEY STB N
+ (fig-forth-auto680):04739 * STX N+1
+ (fig-forth-auto680):04740 * LDB ACIAC
+ (fig-forth-auto680):04741 * ASRB ;
+ (fig-forth-auto680):04742 * BCC PKEY+4 no incoming data yet
+ (fig-forth-auto680):04743 * LDA ACIAD
+ (fig-forth-auto680):04744 * ANDA #$7F strip parity bit
+ (fig-forth-auto680):04745 * LDX UP
+ (fig-forth-auto680):04746 * STB IOSTAT+1-UORIG,X
+ (fig-forth-auto680):04747 * LDB N
+ (fig-forth-auto680):04748 * LDX N+1
+ (fig-forth-auto680):04749 * RTS
+ (fig-forth-auto680):04750 * PKEY JMP $E1AC for MIKBUG
+ (fig-forth-auto680):04751 * PKEY FCB $3F,$14,$39 for PROTO
+ (fig-forth-auto680):04752 * PKEY JMP $D289 for Smoke Signal DOS
+ (fig-forth-auto680):04753 *
+ (fig-forth-auto680):04754 * ######>> screen 64 <<
+ (fig-forth-auto680):04755 * ======>> 184 << code for ?TERMINAL
+ (fig-forth-auto680):04756 * ( --- f ) Should change this to no stack effect.
+ (fig-forth-auto680):04757 * check break key using POLCAT
+ (fig-forth-auto680):04758 * Returns a flag to tell whether the break key was pressed or not.
+25E2 3468 (fig-forth-auto680):04759 PQTER PSHS Y,U,DP
+25E4 5F (fig-forth-auto680):04760 CLRB
+25E5 1F9B (fig-forth-auto680):04761 TFR B,DP
+25E7 AD9FA000 (fig-forth-auto680):04762 JSR [$A000] ; Look but don't wait.
+25EB 20EB (fig-forth-auto680):04763 BRA PKEYR
+ (fig-forth-auto680):04764 * PQTER LDA ACIAC Test for 'break' condition
+ (fig-forth-auto680):04765 * ANDA #$11 mask framing error bit and
+ (fig-forth-auto680):04766 * input buffer full
+ (fig-forth-auto680):04767 * BEQ PQTER2
+ (fig-forth-auto680):04768 * LDA ACIAD clear input buffer
+ (fig-forth-auto680):04769 * LDA #01
+ (fig-forth-auto680):04770 * PQTER2 RTS
+ (fig-forth-auto680):04771
+ (fig-forth-auto680):04772
+ (fig-forth-auto680):04773 PAGE
+ (fig-forth-auto680):04774 *
+ (fig-forth-auto680):04775 * ======>> 185 << code for CR
+ (fig-forth-auto680):04776 * ( --- ) No stack effect.
+ (fig-forth-auto680):04777 * Interfaces directly with ROM.
+ (fig-forth-auto680):04778 * For Coco just output a CR.
+ (fig-forth-auto680):04779 * Also subject to redirection in Coco BASIC ROM.
+25ED C60D (fig-forth-auto680):04780 PCR LDB #$0D
+25EF 20BF (fig-forth-auto680):04781 BRA PEMIT ; Just steal the code.
+ (fig-forth-auto680):04782 * PCR LDA #$D carriage return
+ (fig-forth-auto680):04783 * BSR PEMIT
+ (fig-forth-auto680):04784 * LDA #$A line feed
+ (fig-forth-auto680):04785 * BSR PEMIT
+ (fig-forth-auto680):04786 * LDA #$7F rubout
+ (fig-forth-auto680):04787 * LDX UP
+ (fig-forth-auto680):04788 * LDB XDELAY+1-UORIG,X
+ (fig-forth-auto680):04789 * PCR2 DECB ;
+ (fig-forth-auto680):04790 * BMI PQTER2 return if minus
+ (fig-forth-auto680):04791 * PSHS B ; save counter
+ (fig-forth-auto680):04792 * BSR PEMIT print RUBOUTs to delay.....
+ (fig-forth-auto680):04793 * PULS B ;
+ (fig-forth-auto680):04794 * BRA PCR2 repeat
+ (fig-forth-auto680):04795
+ (fig-forth-auto680):04796
+ (fig-forth-auto680):04797 PAGE
+ (fig-forth-auto680):04798 *
+ (fig-forth-auto680):04799 * ######>> screen 66 <<
+ (fig-forth-auto680):04800 * ======>> 187 <<
+ (fig-forth-auto680):04801 * ( ??? )
+ (fig-forth-auto680):04802 * Query the disk, I suppose.
+ (fig-forth-auto680):04803 * Not sure what the model had in mind for this stub.
+25F1 85 (fig-forth-auto680):04804 FCB $85
+25F2 3F444953 (fig-forth-auto680):04805 FCC '?DIS' ; '?DISC'
+25F6 C3 (fig-forth-auto680):04806 FCB $C3
+25F7 258E (fig-forth-auto680):04807 FDB ARROW-6
+25F9 25FB (fig-forth-auto680):04808 QDISC FDB *+NATWID
+25FB 7E1228 (fig-forth-auto680):04809 JMP NEXT
+ (fig-forth-auto680):04810 *
+ (fig-forth-auto680):04811 * ######>> screen 67 <<
+ (fig-forth-auto680):04812 * ======>> 189 <<
+ (fig-forth-auto680):04813 * ( ??? )
+ (fig-forth-auto680):04814 * Write one block of data to disk.
+ (fig-forth-auto680):04815 * Parameters unspecified in model. Stub in model.
+25FE 8B (fig-forth-auto680):04816 FCB $8B
+25FF 424C4F434B2D5752 (fig-forth-auto680):04817 FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
+ 4954
+2609 C5 (fig-forth-auto680):04818 FCB $C5
+260A 25F1 (fig-forth-auto680):04819 FDB QDISC-8
+260C 260E (fig-forth-auto680):04820 BWRITE FDB *+NATWID
+260E 7E1228 (fig-forth-auto680):04821 JMP NEXT
+ (fig-forth-auto680):04822 *
+ (fig-forth-auto680):04823 * ######>> screen 68 <<
+ (fig-forth-auto680):04824 * ======>> 190 <<
+ (fig-forth-auto680):04825 * ( ??? )
+ (fig-forth-auto680):04826 * Read one block of data from disk.
+ (fig-forth-auto680):04827 * Parameters unspecified in model. Stub in model.
+2611 8A (fig-forth-auto680):04828 FCB $8A
+2612 424C4F434B2D5245 (fig-forth-auto680):04829 FCC 'BLOCK-REA' ; 'BLOCK-READ'
+ 41
+261B C4 (fig-forth-auto680):04830 FCB $C4
+261C 25FE (fig-forth-auto680):04831 FDB BWRITE-14
+261E 2620 (fig-forth-auto680):04832 BREAD FDB *+NATWID
+2620 7E1228 (fig-forth-auto680):04833 JMP NEXT
+ (fig-forth-auto680):04834 *
+ (fig-forth-auto680):04835 *The next 3 words are written to create a substitute for disc
+ (fig-forth-auto680):04836 * mass memory,located between $3210 & $3FFF in ram.
+ (fig-forth-auto680):04837 * ======>> 190.1 <<
+2623 82 (fig-forth-auto680):04838 FCB $82
+2624 4C (fig-forth-auto680):04839 FCC 'L' ; 'LO'
+2625 CF (fig-forth-auto680):04840 FCB $CF
+2626 2611 (fig-forth-auto680):04841 FDB BREAD-13
+2628 17E9 (fig-forth-auto680):04842 LO FDB DOCON
+262A 7000 (fig-forth-auto680):04843 FDB MEMEND a system dependent equate at front
+ (fig-forth-auto680):04844 *
+ (fig-forth-auto680):04845 * ======>> 190.2 <<
+262C 82 (fig-forth-auto680):04846 FCB $82
+262D 48 (fig-forth-auto680):04847 FCC 'H' ; 'HI'
+262E C9 (fig-forth-auto680):04848 FCB $C9
+262F 2623 (fig-forth-auto680):04849 FDB LO-5
+2631 17E9 (fig-forth-auto680):04850 HI FDB DOCON
+2633 7FFF (fig-forth-auto680):04851 FDB MEMTOP ( $3FFF or $7FFF in this version )
+ (fig-forth-auto680):04852 *
+ (fig-forth-auto680):04853 * ######>> screen 69 <<
+ (fig-forth-auto680):04854 * ======>> 191 <<
+ (fig-forth-auto680):04855 * ( buffer sector f --- )
+ (fig-forth-auto680):04856 * Read or Write the specified (absolute -- ignores OFFSET) sector
+ (fig-forth-auto680):04857 * from or to the specified buffer.
+ (fig-forth-auto680):04858 * A zero flag specifies write,
+ (fig-forth-auto680):04859 * non-zero specifies read.
+ (fig-forth-auto680):04860 * Sector is an unsigned integer,
+ (fig-forth-auto680):04861 * buffer is the buffer's address.
+ (fig-forth-auto680):04862 * Will need to use the CoCo ROM disk routines.
+ (fig-forth-auto680):04863 * For now, provides a virtual disk in RAM.
+2635 83 (fig-forth-auto680):04864 FCB $83
+2636 522F (fig-forth-auto680):04865 FCC 'R/' ; 'R/W'
+2638 D7 (fig-forth-auto680):04866 FCB $D7
+2639 262C (fig-forth-auto680):04867 FDB HI-5
+263B 17B9168118822306 (fig-forth-auto680):04868 RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
+ 262816C617452631
+ 1A351409
+264F 000D (fig-forth-auto680):04869 FDB RW2-*-NATWID
+2651 1D10 (fig-forth-auto680):04870 FDB PDOTQ
+2653 08 (fig-forth-auto680):04871 FCB 8
+2654 2052616E6765203F (fig-forth-auto680):04872 FCC ' Range ?' ; ' Range ?'
+265C 21D7 (fig-forth-auto680):04873 FDB QUIT
+265E 16901409 (fig-forth-auto680):04874 RW2 FDB FROMR,ZBRAN
+2662 0002 (fig-forth-auto680):04875 FDB RW3-*-NATWID
+2664 1736 (fig-forth-auto680):04876 FDB SWAP
+2666 18821584 (fig-forth-auto680):04877 RW3 FDB BBUF,CMOVE
+266A 1667 (fig-forth-auto680):04878 FDB SEMIS
+ (fig-forth-auto680):04879 *
+ (fig-forth-auto680):04880 * From BIF-6809:
+ (fig-forth-auto680):04881 * RW PSHS Y,U,DP
+ (fig-forth-auto680):04882 * LDY $C006 control table
+ (fig-forth-auto680):04883 * LDX #DROFFS+7 ; This is BIF's table of drive sizes.
+ (fig-forth-auto680):04884 * LDD 2,U
+ (fig-forth-auto680):04885 * RWD SUBD ,X++ sectors
+ (fig-forth-auto680):04886 * BHS RWD
+ (fig-forth-auto680):04887 * BVC RWR table end?
+ (fig-forth-auto680):04888 * LDD #6
+ (fig-forth-auto680):04889 * PSHU D
+ (fig-forth-auto680):04890 * JMP ERROR
+ (fig-forth-auto680):04891 * RWR ADDD ,--X back one
+ (fig-forth-auto680):04892 * PSHS X
+ (fig-forth-auto680):04893 * PSHU D
+ (fig-forth-auto680):04894 * LDD #18 sectors/track
+ (fig-forth-auto680):04895 * PSHU D
+ (fig-forth-auto680):04896 * DOCOL
+ (fig-forth-auto680):04897 * FDB SLAMOD
+ (fig-forth-auto680):04898 * FDB XMACH
+ (fig-forth-auto680):04899 * PULU D
+ (fig-forth-auto680):04900 * STB 2,Y track
+ (fig-forth-auto680):04901 * PULU D
+ (fig-forth-auto680):04902 * INCB
+ (fig-forth-auto680):04903 * STB 3,Y sector
+ (fig-forth-auto680):04904 * PULS D table entry
+ (fig-forth-auto680):04905 * SUBD #DROFFS+7
+ (fig-forth-auto680):04906 * ASRB drive #
+ (fig-forth-auto680):04907 * STB 1,Y
+ (fig-forth-auto680):04908 * LDD 4,U buffer
+ (fig-forth-auto680):04909 * STD 4,Y
+ (fig-forth-auto680):04910 * LDB #2 coco READ
+ (fig-forth-auto680):04911 * LDX ,U 0?
+ (fig-forth-auto680):04912 * BNE *+3
+ (fig-forth-auto680):04913 * INCB coco WRITE
+ (fig-forth-auto680):04914 * STB ,Y op code
+ (fig-forth-auto680):04915 * CLRA
+ (fig-forth-auto680):04916 * TFR A,DP
+ (fig-forth-auto680):04917 * JSR [$C004] ROM handles timeout
+ (fig-forth-auto680):04918 * PULS Y,U,DP if IRQ enabled
+ (fig-forth-auto680):04919 * LEAU 6,U
+ (fig-forth-auto680):04920 * LDX $C006
+ (fig-forth-auto680):04921 * LDB 6,X coco status
+ (fig-forth-auto680):04922 * BEQ RWE
+ (fig-forth-auto680):04923 * LDX <UP
+ (fig-forth-auto680):04924 * LDD #0 no disc
+ (fig-forth-auto680):04925 * STD UWARN,X
+ (fig-forth-auto680):04926 * LDD #8
+ (fig-forth-auto680):04927 * PSHU D
+ (fig-forth-auto680):04928 * JMP ERROR
+ (fig-forth-auto680):04929 * RWE NEXT
+ (fig-forth-auto680):04930 *
+ (fig-forth-auto680):04931 * ######>> screen 72 <<
+ (fig-forth-auto680):04932 * ======>> 192 <<
+ (fig-forth-auto680):04933 * ( --- ) compiling P
+ (fig-forth-auto680):04934 * ( --- adr ) interpreting
+ (fig-forth-auto680):04935 * { ' name } input
+ (fig-forth-auto680):04936 * Parse a symbol name from input and search the dictionary for it, per -FIND;
+ (fig-forth-auto680):04937 * compile the address as a literal if compiling,
+ (fig-forth-auto680):04938 * otherwise just push it.
+266C C1 (fig-forth-auto680):04939 FCB $C1 immediate
+266D A7 (fig-forth-auto680):04940 FCB $A7 ' ( tick )
+266E 2635 (fig-forth-auto680):04941 FDB RW-6
+2670 17B91FAD16A3183D (fig-forth-auto680):04942 TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
+ 1B39172A20E2
+267E 1667 (fig-forth-auto680):04943 FDB SEMIS
+ (fig-forth-auto680):04944 *
+ (fig-forth-auto680):04945 * ======>> 193 <<
+ (fig-forth-auto680):04946 * ( --- ) { FORGET name } input
+ (fig-forth-auto680):04947 * Parse out name of definition to FORGET to, -DFIND it,
+ (fig-forth-auto680):04948 * then lop it and everything that follows out of the dictionary.
+ (fig-forth-auto680):04949 * In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
+2680 86 (fig-forth-auto680):04950 FCB $86
+2681 464F524745 (fig-forth-auto680):04951 FCC 'FORGE' ; 'FORGET'
+2686 D4 (fig-forth-auto680):04952 FCB $D4
+2687 266C (fig-forth-auto680):04953 FDB TICK-4
+2689 17B9194C1772193E (fig-forth-auto680):04954 FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
+ 17721A0413A7
+2697 18 (fig-forth-auto680):04955 FCB $18
+2698 1B392670174518E4 (fig-forth-auto680):04956 FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT8
+ 17721A1D13A7
+26A6 15 (fig-forth-auto680):04957 FCB $15
+26A7 1B391745183D189C (fig-forth-auto680):04958 FDB QERR,DUP,ZERO,PORIG,GREAT,LIT8
+ 1A3513A7
+26B3 15 (fig-forth-auto680):04959 FCB $15
+26B4 1B3917451AFD18ED (fig-forth-auto680):04960 FDB QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
+ 178A1AE01772193E
+ 1772178A
+26C8 1667 (fig-forth-auto680):04961 FDB SEMIS
+ (fig-forth-auto680):04962 *
+ (fig-forth-auto680):04963 * ######>> screen 73 <<
+ (fig-forth-auto680):04964 * ======>> 194 <<
+ (fig-forth-auto680):04965 * ( adr --- ) C
+ (fig-forth-auto680):04966 * Calculate a back reference from HERE and compile it.
+26CA 84 (fig-forth-auto680):04967 FCB $84
+26CB 424143 (fig-forth-auto680):04968 FCC 'BAC' ; 'BACK'
+26CE CB (fig-forth-auto680):04969 FCB $CB
+26CF 2680 (fig-forth-auto680):04970 FDB FORGET-9
+ (fig-forth-auto680):04971 * BACK FDB DOCOL,HERE,SUB,COMMA
+26D1 17B919C718021A04 (fig-forth-auto680):04972 BACK FDB DOCOL,HERE,NATP,SUB,COMMA
+ 19E3
+26DB 1667 (fig-forth-auto680):04973 FDB SEMIS
+ (fig-forth-auto680):04974 *
+ (fig-forth-auto680):04975 * ======>> 195 <<
+ (fig-forth-auto680):04976 * ( --- ) runtime
+ (fig-forth-auto680):04977 * typical use: BEGIN code-loop test UNTIL
+ (fig-forth-auto680):04978 * typical use: BEGIN code-loop AGAIN
+ (fig-forth-auto680):04979 * typical use: BEGIN code-loop test WHILE code-true REPEAT
+ (fig-forth-auto680):04980 * ( --- adr n ) compile time P,C
+ (fig-forth-auto680):04981 * Push HERE for BACK reference for general (non-counting) loops,
+ (fig-forth-auto680):04982 * with BEGIN construct flag.
+ (fig-forth-auto680):04983 * A better flag: $4245 (ASCII for 'BE').
+26DD C5 (fig-forth-auto680):04984 FCB $C5
+26DE 42454749 (fig-forth-auto680):04985 FCC 'BEGI' ; 'BEGIN'
+26E2 CE (fig-forth-auto680):04986 FCB $CE
+26E3 26CA (fig-forth-auto680):04987 FDB BACK-7
+26E5 17B91B5319C71845 (fig-forth-auto680):04988 BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
+26ED 1667 (fig-forth-auto680):04989 FDB SEMIS
+ (fig-forth-auto680):04990 *
+ (fig-forth-auto680):04991 * ======>> 196 <<
+ (fig-forth-auto680):04992 * ( --- ) runtime
+ (fig-forth-auto680):04993 * typical use: test IF code-true ELSE code-false ENDIF
+ (fig-forth-auto680):04994 * ENDIF is just a sort of intersection piece,
+ (fig-forth-auto680):04995 * marking where execution resumes after both branches.
+ (fig-forth-auto680):04996 * ( adr n --- ) compile time
+ (fig-forth-auto680):04997 * Check the mark and resolve the IF.
+ (fig-forth-auto680):04998 * A better flag: $4846 (ASCII for 'IF').
+26EF C5 (fig-forth-auto680):04999 FCB $C5
+26F0 454E4449 (fig-forth-auto680):05000 FCC 'ENDI' ; 'ENDIF'
+26F4 C6 (fig-forth-auto680):05001 FCB $C6
+26F5 26DD (fig-forth-auto680):05002 FDB BEGIN-8
+26F7 17B91B53184D1B80 (fig-forth-auto680):05003 ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
+ 19C7
+2701 171C18021A041736 (fig-forth-auto680):05004 FDB OVER,NATP,SUB,SWAP,STORE
+ 178A
+270B 1667 (fig-forth-auto680):05005 FDB SEMIS
+ (fig-forth-auto680):05006 *
+ (fig-forth-auto680):05007 * ======>> 197 <<
+ (fig-forth-auto680):05008 * ( --- ) runtime
+ (fig-forth-auto680):05009 * typical use: test IF code-true ELSE code-false ENDIF
+ (fig-forth-auto680):05010 * ( adr n --- )
+ (fig-forth-auto680):05011 * Alias for ENDIF .
+270D C4 (fig-forth-auto680):05012 FCB $C4
+270E 544845 (fig-forth-auto680):05013 FCC 'THE' ; 'THEN'
+2711 CE (fig-forth-auto680):05014 FCB $CE
+2712 26EF (fig-forth-auto680):05015 FDB ENDIF-8
+2714 17B926F7 (fig-forth-auto680):05016 THEN FDB DOCOL,ENDIF
+2718 1667 (fig-forth-auto680):05017 FDB SEMIS
+ (fig-forth-auto680):05018 *
+ (fig-forth-auto680):05019 * ======>> 198 <<
+ (fig-forth-auto680):05020 * ( limit index --- ) runtime
+ (fig-forth-auto680):05021 * typical use: DO code-loop LOOP
+ (fig-forth-auto680):05022 * typical use: DO code-loop increment +LOOP
+ (fig-forth-auto680):05023 * Counted loop, index is initial value of index.
+ (fig-forth-auto680):05024 * Will loop until index equals (positive going)
+ (fig-forth-auto680):05025 * or passes (negative going) limit.
+ (fig-forth-auto680):05026 * ( --- adr n ) compile time P,C
+ (fig-forth-auto680):05027 * Compile (DO), push HERE for BACK reference,
+ (fig-forth-auto680):05028 * and push DO control construct flag.
+ (fig-forth-auto680):05029 * A better flag: $444F (ASCII for 'DO').
+271A C2 (fig-forth-auto680):05030 FCB $C2
+271B 44 (fig-forth-auto680):05031 FCC 'D' ; 'DO'
+271C CF (fig-forth-auto680):05032 FCB $CF
+271D 270D (fig-forth-auto680):05033 FDB THEN-7
+271F 17B91BC7145319C7 (fig-forth-auto680):05034 DO FDB DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
+ 1855
+2729 1667 (fig-forth-auto680):05035 FDB SEMIS
+ (fig-forth-auto680):05036 *
+ (fig-forth-auto680):05037 * ======>> 199 <<
+ (fig-forth-auto680):05038 * ( --- ) runtime
+ (fig-forth-auto680):05039 * typical use: DO code-loop LOOP
+ (fig-forth-auto680):05040 * Increments the index by one and branches back to beginning of loop.
+ (fig-forth-auto680):05041 * Will loop until index equals limit.
+ (fig-forth-auto680):05042 * ( adr n --- ) compile time P,C
+ (fig-forth-auto680):05043 * Check the mark and compile (LOOP), fill in BACK reference.
+ (fig-forth-auto680):05044 * A better flag: $444F (ASCII for 'DO').
+272B C4 (fig-forth-auto680):05045 FCB $C4
+272C 4C4F4F (fig-forth-auto680):05046 FCC 'LOO' ; 'LOOP'
+272F D0 (fig-forth-auto680):05047 FCB $D0
+2730 271A (fig-forth-auto680):05048 FDB DO-5
+2732 17B918551B801BC7 (fig-forth-auto680):05049 LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
+ 141D26D1
+273E 1667 (fig-forth-auto680):05050 FDB SEMIS
+ (fig-forth-auto680):05051 *
+ (fig-forth-auto680):05052 * ======>> 200 <<
+ (fig-forth-auto680):05053 * ( n --- ) runtime
+ (fig-forth-auto680):05054 * typical use: DO code-loop increment +LOOP
+ (fig-forth-auto680):05055 * Increments the index by n and branches back to beginning of loop.
+ (fig-forth-auto680):05056 * Will loop until index equals (positive going)
+ (fig-forth-auto680):05057 * or passes (negative going) limit.
+ (fig-forth-auto680):05058 * ( adr n --- ) compile time P,C
+ (fig-forth-auto680):05059 * Check the mark and compile (+LOOP), fill in BACK reference.
+ (fig-forth-auto680):05060 * A better flag: $444F (ASCII for 'DO').
+2740 C5 (fig-forth-auto680):05061 FCB $C5
+2741 2B4C4F4F (fig-forth-auto680):05062 FCC '+LOO' ; '+LOOP'
+2745 D0 (fig-forth-auto680):05063 FCB $D0
+2746 272B (fig-forth-auto680):05064 FDB LOOP-7
+2748 17B918551B801BC7 (fig-forth-auto680):05065 PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
+ 143C26D1
+2754 1667 (fig-forth-auto680):05066 FDB SEMIS
+ (fig-forth-auto680):05067 *
+ (fig-forth-auto680):05068 * ======>> 201 <<
+ (fig-forth-auto680):05069 * ( n --- ) runtime
+ (fig-forth-auto680):05070 * typical use: BEGIN code-loop test UNTIL
+ (fig-forth-auto680):05071 * Will loop until UNTIL tests true.
+ (fig-forth-auto680):05072 * ( adr n --- ) compile time P,C
+ (fig-forth-auto680):05073 * Check the mark and compile (0BRANCH), fill in BACK reference.
+ (fig-forth-auto680):05074 * A better flag: $4245 (ASCII for 'BE').
+2756 C5 (fig-forth-auto680):05075 FCB $C5
+2757 554E5449 (fig-forth-auto680):05076 FCC 'UNTI' ; 'UNTIL' : ( same as END )
+275B CC (fig-forth-auto680):05077 FCB $CC
+275C 2740 (fig-forth-auto680):05078 FDB PLOOP-8
+275E 17B918451B801BC7 (fig-forth-auto680):05079 UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
+ 140926D1
+276A 1667 (fig-forth-auto680):05080 FDB SEMIS
+ (fig-forth-auto680):05081 *
+ (fig-forth-auto680):05082 * ######>> screen 74 <<
+ (fig-forth-auto680):05083 * ======>> 202 <<
+ (fig-forth-auto680):05084 * ( n --- ) runtime
+ (fig-forth-auto680):05085 * typical use: BEGIN code-loop test END
+ (fig-forth-auto680):05086 * ( adr n --- )
+ (fig-forth-auto680):05087 * Alias for UNTIL .
+276C C3 (fig-forth-auto680):05088 FCB $C3
+276D 454E (fig-forth-auto680):05089 FCC 'EN' ; 'END'
+276F C4 (fig-forth-auto680):05090 FCB $C4
+2770 2756 (fig-forth-auto680):05091 FDB UNTIL-8
+2772 17B9275E (fig-forth-auto680):05092 END FDB DOCOL,UNTIL
+2776 1667 (fig-forth-auto680):05093 FDB SEMIS
+ (fig-forth-auto680):05094 *
+ (fig-forth-auto680):05095 * ======>> 203 <<
+ (fig-forth-auto680):05096 * ( --- ) runtime
+ (fig-forth-auto680):05097 * typical use: BEGIN code-loop AGAIN
+ (fig-forth-auto680):05098 * Will loop forever
+ (fig-forth-auto680):05099 * (or until something uses R> DROP to force the current definition to die,
+ (fig-forth-auto680):05100 * or perhaps ABORT or ERROR or some such other drastic means stops things).
+ (fig-forth-auto680):05101 * ( adr n --- ) compile time P,C
+ (fig-forth-auto680):05102 * Check the mark and compile (0BRANCH), fill in BACK reference.
+ (fig-forth-auto680):05103 * A better flag: $4245 (ASCII for 'BE').
+2778 C5 (fig-forth-auto680):05104 FCB $C5
+2779 41474149 (fig-forth-auto680):05105 FCC 'AGAI' ; 'AGAIN'
+277D CE (fig-forth-auto680):05106 FCB $CE
+277E 276C (fig-forth-auto680):05107 FDB END-6
+2780 17B918451B801BC7 (fig-forth-auto680):05108 AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
+ 13FA26D1
+278C 1667 (fig-forth-auto680):05109 FDB SEMIS
+ (fig-forth-auto680):05110 *
+ (fig-forth-auto680):05111 * ======>> 204 <<
+ (fig-forth-auto680):05112 * ( --- ) runtime
+ (fig-forth-auto680):05113 * typical use: BEGIN code-loop test WHILE code-true REPEAT
+ (fig-forth-auto680):05114 * Will loop until WHILE tests false, skipping code-true on end.
+ (fig-forth-auto680):05115 * REPEAT marks where execution resumes after the WHILE find a false flag.
+ (fig-forth-auto680):05116 * ( aadr1 n1 adr2 n2 --- ) compile time P,C
+ (fig-forth-auto680):05117 * Check the marks for WHILE and BEGIN,
+ (fig-forth-auto680):05118 * compile BRANCH and BACK fill adr1 reference,
+ (fig-forth-auto680):05119 * FILL-IN 0BRANCH reference at adr2.
+ (fig-forth-auto680):05120 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+278E C6 (fig-forth-auto680):05121 FCB $C6
+278F 5245504541 (fig-forth-auto680):05122 FCC 'REPEA' ; 'REPEAT'
+2794 D4 (fig-forth-auto680):05123 FCB $D4
+2795 2778 (fig-forth-auto680):05124 FDB AGAIN-8
+2797 17B9168116812780 (fig-forth-auto680):05125 REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
+ 16901690
+27A3 184D1A0426F7 (fig-forth-auto680):05126 FDB TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
+27A9 1667 (fig-forth-auto680):05127 FDB SEMIS
+ (fig-forth-auto680):05128 *
+ (fig-forth-auto680):05129 * ======>> 205 <<
+ (fig-forth-auto680):05130 * ( n --- ) runtime
+ (fig-forth-auto680):05131 * typical use: test IF code-true ELSE code-false ENDIF
+ (fig-forth-auto680):05132 * Will pass execution to the true part on a true flag
+ (fig-forth-auto680):05133 * and to the false part on a false flag.
+ (fig-forth-auto680):05134 * ( --- adr n ) compile time P,C
+ (fig-forth-auto680):05135 * Compile a 0BRANCH and dummy offset
+ (fig-forth-auto680):05136 * and push IF reference to fill in and
+ (fig-forth-auto680):05137 * IF control construct flag.
+ (fig-forth-auto680):05138 * A better flag: $4946 (ASCII for 'IF').
+27AB C2 (fig-forth-auto680):05139 FCB $C2
+27AC 49 (fig-forth-auto680):05140 FCC 'I' ; 'IF'
+27AD C6 (fig-forth-auto680):05141 FCB $C6
+27AE 278E (fig-forth-auto680):05142 FDB REPEAT-9
+27B0 17B91BC7140919C7 (fig-forth-auto680):05143 IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
+ 183D19E3184D
+27BE 1667 (fig-forth-auto680):05144 FDB SEMIS
+ (fig-forth-auto680):05145 *
+ (fig-forth-auto680):05146 * ======>> 206 <<
+ (fig-forth-auto680):05147 * ( --- ) runtime
+ (fig-forth-auto680):05148 * typical use: test IF code-true ELSE code-false ENDIF
+ (fig-forth-auto680):05149 * ELSE is just a sort of intersection piece,
+ (fig-forth-auto680):05150 * marking where execution resumes on a false branch.
+ (fig-forth-auto680):05151 * ( adr1 n --- adr2 n ) compile time P,C
+ (fig-forth-auto680):05152 * Check the marks,
+ (fig-forth-auto680):05153 * compile BRANCH with dummy offset,
+ (fig-forth-auto680):05154 * resolve IF reference,
+ (fig-forth-auto680):05155 * and leave reference to BRANCH for ELSE.
+ (fig-forth-auto680):05156 * A better flag: $4946 (ASCII for 'IF').
+27C0 C4 (fig-forth-auto680):05157 FCB $C4
+27C1 454C53 (fig-forth-auto680):05158 FCC 'ELS' ; 'ELSE'
+27C4 C5 (fig-forth-auto680):05159 FCB $C5
+27C5 27AB (fig-forth-auto680):05160 FDB IF-5
+27C7 17B9184D1B801BC7 (fig-forth-auto680):05161 ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
+ 13FA19C7
+27D3 183D19E31736184D (fig-forth-auto680):05162 FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
+ 26F7184D
+27DF 1667 (fig-forth-auto680):05163 FDB SEMIS
+ (fig-forth-auto680):05164 *
+ (fig-forth-auto680):05165 * ======>> 207 <<
+ (fig-forth-auto680):05166 * ( n --- ) runtime
+ (fig-forth-auto680):05167 * typical use: BEGIN code-loop test WHILE code-true REPEAT
+ (fig-forth-auto680):05168 * Will loop until WHILE tests false, skipping code-true on end.
+ (fig-forth-auto680):05169 * ( --- adr n ) compile time P,C
+ (fig-forth-auto680):05170 * Compile 0BRANCH with dummy offset (using IF),
+ (fig-forth-auto680):05171 * push WHILE reference.
+ (fig-forth-auto680):05172 * BEGIN flag will sit underneath this.
+ (fig-forth-auto680):05173 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+27E1 C5 (fig-forth-auto680):05174 FCB $C5
+27E2 5748494C (fig-forth-auto680):05175 FCC 'WHIL' ; 'WHILE'
+27E6 C5 (fig-forth-auto680):05176 FCB $C5
+27E7 27C0 (fig-forth-auto680):05177 FDB ELSE-7
+27E9 17B927B019B8 (fig-forth-auto680):05178 WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
+27EF 1667 (fig-forth-auto680):05179 FDB SEMIS
+ (fig-forth-auto680):05180 *
+ (fig-forth-auto680):05181 * ######>> screen 75 <<
+ (fig-forth-auto680):05182 * ======>> 208 <<
+ (fig-forth-auto680):05183 * ( count --- )
+ (fig-forth-auto680):05184 * EMIT count spaces, for non-zero, non-negative counts.
+27F1 86 (fig-forth-auto680):05185 FCB $86
+27F2 5350414345 (fig-forth-auto680):05186 FCC 'SPACE' ; 'SPACES'
+27F7 D3 (fig-forth-auto680):05187 FCB $D3
+27F8 27E1 (fig-forth-auto680):05188 FDB WHILE-8
+27FA 17B9183D1A771A8A (fig-forth-auto680):05189 SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
+ 1409
+2804 000A (fig-forth-auto680):05190 FDB SPACE3-*-NATWID
+2806 183D1453 (fig-forth-auto680):05191 FDB ZERO,XDO
+280A 1A57141D (fig-forth-auto680):05192 SPACE2 FDB SPACE,XLOOP
+280E FFFA (fig-forth-auto680):05193 FDB SPACE2-*-NATWID
+2810 1667 (fig-forth-auto680):05194 SPACE3 FDB SEMIS
+ (fig-forth-auto680):05195 *
+ (fig-forth-auto680):05196 * ======>> 209 <<
+ (fig-forth-auto680):05197 * ( --- )
+ (fig-forth-auto680):05198 * Initialize HLD for converting a double integer.
+ (fig-forth-auto680):05199 * Stores the PAD address in HLD.
+2812 82 (fig-forth-auto680):05200 FCB $82
+2813 3C (fig-forth-auto680):05201 FCC '<' ; '<#'
+2814 A3 (fig-forth-auto680):05202 FCB $A3
+2815 27F1 (fig-forth-auto680):05203 FDB SPACES-9
+2817 17B91EAA1994178A (fig-forth-auto680):05204 BDIGS FDB DOCOL,PAD,HLD,STORE
+281F 1667 (fig-forth-auto680):05205 FDB SEMIS
+ (fig-forth-auto680):05206 *
+ (fig-forth-auto680):05207 * ======>> 210 <<
+ (fig-forth-auto680):05208 * ( d --- string length )
+ (fig-forth-auto680):05209 * Terminate numeric conversion,
+ (fig-forth-auto680):05210 * drop the number being converted,
+ (fig-forth-auto680):05211 * leave the address of the conversion string and the length, ready for TYPE.
+2821 82 (fig-forth-auto680):05212 FCB $82
+2822 23 (fig-forth-auto680):05213 FCC '#' ; '#>'
+2823 BE (fig-forth-auto680):05214 FCB $BE
+2824 2812 (fig-forth-auto680):05215 FDB BDIGS-5
+2826 17B9172A172A1994 (fig-forth-auto680):05216 EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
+ 17721EAA171C1A04
+2836 1667 (fig-forth-auto680):05217 FDB SEMIS
+ (fig-forth-auto680):05218 *
+ (fig-forth-auto680):05219 * ======>> 211 <<
+ (fig-forth-auto680):05220 * ( n d --- d )
+ (fig-forth-auto680):05221 * Put sign of n (as a flag) at the head of the conversion string.
+ (fig-forth-auto680):05222 * Drop the sign flag.
+2838 84 (fig-forth-auto680):05223 FCB $84
+2839 534947 (fig-forth-auto680):05224 FCC 'SIG' ; 'SIGN'
+283C CE (fig-forth-auto680):05225 FCB $CE
+283D 2821 (fig-forth-auto680):05226 FDB EDIGS-5
+283F 17B91A4316B51409 (fig-forth-auto680):05227 SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
+2847 0005 (fig-forth-auto680):05228 FDB SIGN2-*-NATWID
+2849 13A7 (fig-forth-auto680):05229 FDB LIT8
+284B 2D (fig-forth-auto680):05230 FCC "-"
+284C 1E92 (fig-forth-auto680):05231 FDB HOLD
+284E 1667 (fig-forth-auto680):05232 SIGN2 FDB SEMIS
+ (fig-forth-auto680):05233 *
+ (fig-forth-auto680):05234 * ======>> 212 <<
+ (fig-forth-auto680):05235 * ( d --- d/base )
+ (fig-forth-auto680):05236 * Generate next most significant digit in the conversion BASE,
+ (fig-forth-auto680):05237 * putting the digit at the head of the conversion string.
+2850 81 (fig-forth-auto680):05238 FCB $81 #
+2851 A3 (fig-forth-auto680):05239 FCB $A3
+2852 2838 (fig-forth-auto680):05240 FDB SIGN-7
+2854 17B9196317722368 (fig-forth-auto680):05241 DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
+ 1A4313A7
+2860 09 (fig-forth-auto680):05242 FCB 9
+2861 171C1A1D1409 (fig-forth-auto680):05243 FDB OVER,LESS,ZBRAN
+2867 0005 (fig-forth-auto680):05244 FDB DIG2-*-NATWID
+2869 13A7 (fig-forth-auto680):05245 FDB LIT8
+286B 07 (fig-forth-auto680):05246 FCB 7
+286C 16C6 (fig-forth-auto680):05247 FDB PLUS
+286E 13A7 (fig-forth-auto680):05248 DIG2 FDB LIT8
+2870 30 (fig-forth-auto680):05249 FCC "0" ascii zero
+2871 16C61E92 (fig-forth-auto680):05250 FDB PLUS,HOLD
+2875 1667 (fig-forth-auto680):05251 FDB SEMIS
+ (fig-forth-auto680):05252 *
+ (fig-forth-auto680):05253 * ======>> 213 <<
+ (fig-forth-auto680):05254 * ( d --- dzero )
+ (fig-forth-auto680):05255 * Convert d to a numeric string using # until the result is zero.
+ (fig-forth-auto680):05256 * Leave the double result on the stack for #> to drop.
+2877 82 (fig-forth-auto680):05257 FCB $82
+2878 23 (fig-forth-auto680):05258 FCC '#' ; '#S'
+2879 D3 (fig-forth-auto680):05259 FCB $D3
+287A 2850 (fig-forth-auto680):05260 FDB DIG-4
+287C 17B9 (fig-forth-auto680):05261 DIGS FDB DOCOL
+287E 2854171C171C161E (fig-forth-auto680):05262 DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
+ 16A31409
+288A FFF2 (fig-forth-auto680):05263 FDB DIGS2-*-NATWID
+288C 1667 (fig-forth-auto680):05264 FDB SEMIS
+ (fig-forth-auto680):05265 *
+ (fig-forth-auto680):05266 * ######>> screen 76 <<
+ (fig-forth-auto680):05267 * ======>> 214 <<
+ (fig-forth-auto680):05268 * ( n width --- )
+ (fig-forth-auto680):05269 * Print n on the output device in the current conversion base,
+ (fig-forth-auto680):05270 * with sign,
+ (fig-forth-auto680):05271 * right aligned in a field at least width wide.
+288E 82 (fig-forth-auto680):05272 FCB $82
+288F 2E (fig-forth-auto680):05273 FCC '.' ; '.R'
+2890 D2 (fig-forth-auto680):05274 FCB $D2
+2891 2877 (fig-forth-auto680):05275 FDB DIGS-5
+2893 17B9168122F81690 (fig-forth-auto680):05276 DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
+ 28A5
+289D 1667 (fig-forth-auto680):05277 FDB SEMIS
+ (fig-forth-auto680):05278 *
+ (fig-forth-auto680):05279 * ======>> 215 <<
+ (fig-forth-auto680):05280 * ( d width --- )
+ (fig-forth-auto680):05281 * Print d on the output device in the current conversion base,
+ (fig-forth-auto680):05282 * with sign,
+ (fig-forth-auto680):05283 * right aligned in a field at least width wide.
+289F 83 (fig-forth-auto680):05284 FCB $83
+28A0 442E (fig-forth-auto680):05285 FCC 'D.' ; 'D.R'
+28A2 D2 (fig-forth-auto680):05286 FCB $D2
+28A3 288E (fig-forth-auto680):05287 FDB DOTR-5
+28A5 17B916811736171C (fig-forth-auto680):05288 DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
+ 23992817287C283F
+28B5 28261690171C1A04 (fig-forth-auto680):05289 FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
+ 27FA1CAF
+28C1 1667 (fig-forth-auto680):05290 FDB SEMIS
+ (fig-forth-auto680):05291 *
+ (fig-forth-auto680):05292 * ======>> 216 <<
+ (fig-forth-auto680):05293 * D. ( d --- )
+ (fig-forth-auto680):05294 * Print d on the output device in the current conversion base,
+ (fig-forth-auto680):05295 * with sign,
+ (fig-forth-auto680):05296 * in free format with trailing space.
+28C3 82 (fig-forth-auto680):05297 FCB $82
+28C4 44 (fig-forth-auto680):05298 FCC 'D' ; 'D.'
+28C5 AE (fig-forth-auto680):05299 FCB $AE
+28C6 289F (fig-forth-auto680):05300 FDB DDOTR-6
+28C8 17B9183D28A51A57 (fig-forth-auto680):05301 DDOT FDB DOCOL,ZERO,DDOTR,SPACE
+28D0 1667 (fig-forth-auto680):05302 FDB SEMIS
+ (fig-forth-auto680):05303 *
+ (fig-forth-auto680):05304 * ======>> 217 <<
+ (fig-forth-auto680):05305 * ( n --- )
+ (fig-forth-auto680):05306 * Print n on the output device in the current conversion base,
+ (fig-forth-auto680):05307 * with sign,
+ (fig-forth-auto680):05308 * in free format with trailing space.
+28D2 81 (fig-forth-auto680):05309 FCB $81 .
+28D3 AE (fig-forth-auto680):05310 FCB $AE
+28D4 28C3 (fig-forth-auto680):05311 FDB DDOT-5
+28D6 17B922F828C8 (fig-forth-auto680):05312 DOT FDB DOCOL,STOD,DDOT
+28DC 1667 (fig-forth-auto680):05313 FDB SEMIS
+ (fig-forth-auto680):05314 *
+ (fig-forth-auto680):05315 * ======>> 218 <<
+ (fig-forth-auto680):05316 * ( adr --- )
+ (fig-forth-auto680):05317 * Print signed word at adr, per DOT.
+28DE 81 (fig-forth-auto680):05318 FCB $81 ?
+28DF BF (fig-forth-auto680):05319 FCB $BF
+28E0 28D2 (fig-forth-auto680):05320 FDB DOT-4
+28E2 17B9177228D6 (fig-forth-auto680):05321 QUEST FDB DOCOL,AT,DOT
+28E8 1667 (fig-forth-auto680):05322 FDB SEMIS
+ (fig-forth-auto680):05323 *
+ (fig-forth-auto680):05324 * ######>> screen 77 <<
+ (fig-forth-auto680):05325 * ======>> 219 <<
+ (fig-forth-auto680):05326 * ( n --- )
+ (fig-forth-auto680):05327 * Print out screen n as a field of ASCII,
+ (fig-forth-auto680):05328 * with line numbers in decimal.
+ (fig-forth-auto680):05329 * Needs a console more than 70 characters wide.
+28EA 84 (fig-forth-auto680):05330 FCB $84
+28EB 4C4953 (fig-forth-auto680):05331 FCC 'LIS' ; 'LIST'
+28EE D4 (fig-forth-auto680):05332 FCB $D4
+28EF 28DE (fig-forth-auto680):05333 FDB QUEST-4
+28F1 17B91C2515771745 (fig-forth-auto680):05334 LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
+ 1923178A1D10
+28FF 06 (fig-forth-auto680):05335 FCB 6
+2900 534352202320 (fig-forth-auto680):05336 FCC "SCR # "
+2906 28D613A7 (fig-forth-auto680):05337 FDB DOT,LIT8
+290A 10 (fig-forth-auto680):05338 FCB $10
+290B 183D1453 (fig-forth-auto680):05339 FDB ZERO,XDO
+290F 157714651855 (fig-forth-auto680):05340 LIST2 FDB CR,I,THREE
+2915 28931A5714651923 (fig-forth-auto680):05341 FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
+ 17722517141D
+2923 FFEA (fig-forth-auto680):05342 FDB LIST2-*-NATWID
+2925 1577 (fig-forth-auto680):05343 FDB CR
+2927 1667 (fig-forth-auto680):05344 FDB SEMIS
+ (fig-forth-auto680):05345 *
+ (fig-forth-auto680):05346 * ======>> 220 <<
+ (fig-forth-auto680):05347 * ( start end --- )
+ (fig-forth-auto680):05348 * Print comment lines (line 0, and line 1 if C/L < 41) of screens
+ (fig-forth-auto680):05349 * from start to end.
+ (fig-forth-auto680):05350 * Needs a console more than 70 characters wide.
+2929 85 (fig-forth-auto680):05351 FCB $85
+292A 494E4445 (fig-forth-auto680):05352 FCC 'INDE' ; 'INDEX'
+292E D8 (fig-forth-auto680):05353 FCB $D8
+292F 28EA (fig-forth-auto680):05354 FDB LIST-7
+2931 17B9157719AB1736 (fig-forth-auto680):05355 INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
+ 1453
+293B 157714651855 (fig-forth-auto680):05356 INDEX2 FDB CR,I,THREE
+2941 28931A57183D1465 (fig-forth-auto680):05357 FDB DOTR,SPACE,ZERO,I,DLINE
+ 2517
+294B 156A1409 (fig-forth-auto680):05358 FDB QTERM,ZBRAN
+294F 0002 (fig-forth-auto680):05359 FDB INDEX3-*-NATWID
+2951 1675 (fig-forth-auto680):05360 FDB LEAVE
+2953 141D (fig-forth-auto680):05361 INDEX3 FDB XLOOP
+2955 FFE4 (fig-forth-auto680):05362 FDB INDEX2-*-NATWID
+2957 1667 (fig-forth-auto680):05363 FDB SEMIS
+ (fig-forth-auto680):05364 *
+ (fig-forth-auto680):05365 * ======>> 221 <<
+ (fig-forth-auto680):05366 * ( n --- )
+ (fig-forth-auto680):05367 * List a printer page full of screens.
+ (fig-forth-auto680):05368 * Line and screen number are in current base.
+ (fig-forth-auto680):05369 * Needs a console more than 70 characters wide.
+2959 85 (fig-forth-auto680):05370 FCB $85
+295A 54524941 (fig-forth-auto680):05371 FCC 'TRIA' ; 'TRIAD'
+295E C4 (fig-forth-auto680):05372 FCB $C4
+295F 2929 (fig-forth-auto680):05373 FDB INDEX-8
+2961 17B9185523251855 (fig-forth-auto680):05374 TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
+ 2306
+296B 1855171C16C61736 (fig-forth-auto680):05375 FDB THREE,OVER,PLUS,SWAP,XDO
+ 1453
+2975 15771465 (fig-forth-auto680):05376 TRIAD2 FDB CR,I
+2979 28F1156A1409 (fig-forth-auto680):05377 FDB LIST,QTERM,ZBRAN
+297F 0002 (fig-forth-auto680):05378 FDB TRIAD3-*-NATWID
+2981 1675 (fig-forth-auto680):05379 FDB LEAVE
+2983 141D (fig-forth-auto680):05380 TRIAD3 FDB XLOOP
+2985 FFEE (fig-forth-auto680):05381 FDB TRIAD2-*-NATWID
+2987 157713A7 (fig-forth-auto680):05382 FDB CR,LIT8
+298B 0F (fig-forth-auto680):05383 FCB $0F
+298C 252B1577 (fig-forth-auto680):05384 FDB MESS,CR
+2990 1667 (fig-forth-auto680):05385 FDB SEMIS
+ (fig-forth-auto680):05386 *
+ (fig-forth-auto680):05387 * ######>> screen 78 <<
+ (fig-forth-auto680):05388 * ======>> 222 <<
+ (fig-forth-auto680):05389 * ( --- )
+ (fig-forth-auto680):05390 * Alphabetically list the definitions in the current vocabulary.
+ (fig-forth-auto680):05391 * Expects to output to printer, not TRS80 Color Computer screen.
+2992 85 (fig-forth-auto680):05392 FCB $85
+2993 564C4953 (fig-forth-auto680):05393 FCC 'VLIS' ; 'VLIST'
+2997 D4 (fig-forth-auto680):05394 FCB $D4
+2998 2959 (fig-forth-auto680):05395 FDB TRIAD-8
+299A 17B913A7 (fig-forth-auto680):05396 VLIST FDB DOCOL,LIT8
+299E 80 (fig-forth-auto680):05397 FCB $80
+299F 1919178A193E1772 (fig-forth-auto680):05398 FDB OUT,STORE,CONTXT,AT,AT
+ 1772
+29A9 1919177219A21772 (fig-forth-auto680):05399 VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
+ 13A7
+29B3 20 (fig-forth-auto680):05400 FCB 32
+29B4 1A041A351409 (fig-forth-auto680):05401 FDB SUB,GREAT,ZBRAN
+29BA 0008 (fig-forth-auto680):05402 FDB VLIST2-*-NATWID
+29BC 1577183D1919178A (fig-forth-auto680):05403 FDB CR,ZERO,OUT,STORE
+29C4 174520301A571A57 (fig-forth-auto680):05404 VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
+ 1B121AE01772
+29D2 174516A3156A161E (fig-forth-auto680):05405 FDB DUP,ZEQU,QTERM,OR,ZBRAN
+ 1409
+29DC FFCB (fig-forth-auto680):05406 FDB VLIST1-*-NATWID
+29DE 172A (fig-forth-auto680):05407 FDB DROP
+29E0 1667 (fig-forth-auto680):05408 FDB SEMIS
+ (fig-forth-auto680):05409 *
+ (fig-forth-auto680):05410 * Need some utility stuff that isn't in the fig FORTH:
+ (fig-forth-auto680):05411 * ( c --- )
+ (fig-forth-auto680):05412 * Emit dot if c is less than blank, else emit c
+29E2 85 (fig-forth-auto680):05413 FCB $85
+29E3 42454D49 (fig-forth-auto680):05414 FCC 'BEMI' ; 'BEMIT'
+29E7 D4 (fig-forth-auto680):05415 FCB $D4 ; 'T'
+29E8 2992 (fig-forth-auto680):05416 FDB VLIST-8
+29EA 17B9 (fig-forth-auto680):05417 BEMIT FDB DOCOL
+29EC 1745185E1A1D1409 (fig-forth-auto680):05418 FDB DUP,BL,LESS,ZBRAN
+29F4 0005 (fig-forth-auto680):05419 FDB BEMITO-*-NATWID
+29F6 172A13A7 (fig-forth-auto680):05420 FDB DROP,LIT8
+29FA 2E (fig-forth-auto680):05421 FCB $2e ; '.'
+29FB 1542 (fig-forth-auto680):05422 BEMITO FDB EMIT
+29FD 1667 (fig-forth-auto680):05423 FDB SEMIS
+ (fig-forth-auto680):05424 *
+ (fig-forth-auto680):05425 * ( n width --- )
+ (fig-forth-auto680):05426 * Output n in hexadecimal field width.
+29FF 83 (fig-forth-auto680):05427 FCB $83
+2A00 582E (fig-forth-auto680):05428 FCC 'X.' ; 'X.R'
+2A02 D2 (fig-forth-auto680):05429 FCB $D2 ; 'R'
+2A03 29E2 (fig-forth-auto680):05430 FDB BEMIT-8
+2A05 17B9 (fig-forth-auto680):05431 XDOTR FDB DOCOL
+2A07 1963177216811C10 (fig-forth-auto680):05432 FDB BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
+ 289316901963178A
+2A17 1667 (fig-forth-auto680):05433 FDB SEMIS
+ (fig-forth-auto680):05434 *
+ (fig-forth-auto680):05435 * ( adr --- )
+ (fig-forth-auto680):05436 * Dump a line of 4 bytes in memory, in hex and as characters.
+2A19 85 (fig-forth-auto680):05437 FCB $85
+2A1A 424C494E (fig-forth-auto680):05438 FCC 'BLIN' ; 'BLINE'
+2A1E C5 (fig-forth-auto680):05439 FCB $C5 ; 'E'
+2A1F 29FF (fig-forth-auto680):05440 FDB XDOTR-6
+2A21 17B9 (fig-forth-auto680):05441 BLINE FDB DOCOL
+2A23 174513A7 (fig-forth-auto680):05442 FDB DUP,LIT8
+2A27 04 (fig-forth-auto680):05443 FCB 4
+2A28 16C6171C1453 (fig-forth-auto680):05444 FDB PLUS,OVER,XDO
+2A2E 1465177E18552A05 (fig-forth-auto680):05445 BLINEX FDB I,CAT,THREE,XDOTR,XLOOP
+ 141D
+2A38 FFF4 (fig-forth-auto680):05446 FDB BLINEX-*-NATWID
+2A3A 1A571A57 (fig-forth-auto680):05447 FDB SPACE,SPACE
+2A3E 174513A7 (fig-forth-auto680):05448 FDB DUP,LIT8
+2A42 04 (fig-forth-auto680):05449 FCB 4
+2A43 17361453 (fig-forth-auto680):05450 FDB SWAP,XDO
+2A47 1465177E29EA141D (fig-forth-auto680):05451 BLINEC FDB I,CAT,BEMIT,XLOOP
+2A4F FFF6 (fig-forth-auto680):05452 FDB BLINEC-*-NATWID
+2A51 1667 (fig-forth-auto680):05453 FDB SEMIS
+ (fig-forth-auto680):05454 *
+ (fig-forth-auto680):05455 * ( start end --- )
+ (fig-forth-auto680):05456 * Dump 4 byte lines from start to end.
+2A53 85 (fig-forth-auto680):05457 FCB $85
+2A54 4244554D (fig-forth-auto680):05458 FCC 'BDUM' ; 'BDUMP'
+2A58 D0 (fig-forth-auto680):05459 FCB $D0 ; '5'
+2A59 2A19 (fig-forth-auto680):05460 FDB BLINE-8
+2A5B 17B9 (fig-forth-auto680):05461 BDUMP FDB DOCOL
+2A5D 1453 (fig-forth-auto680):05462 FDB XDO
+2A5F 146513A7 (fig-forth-auto680):05463 BDUMPL FDB I,LIT8
+2A63 04 (fig-forth-auto680):05464 FCB 4
+2A64 2A0513A7 (fig-forth-auto680):05465 FDB XDOTR,LIT8
+2A68 3A (fig-forth-auto680):05466 FCB $3A
+2A69 15421A57 (fig-forth-auto680):05467 FDB EMIT,SPACE
+2A6D 14652A21157713A7 (fig-forth-auto680):05468 FDB I,BLINE,CR,LIT8
+2A75 04 (fig-forth-auto680):05469 FCB 4
+2A76 143C (fig-forth-auto680):05470 FDB XPLOOP
+2A78 FFE5 (fig-forth-auto680):05471 FDB BDUMPL-*-NATWID
+2A7A 1667 (fig-forth-auto680):05472 FDB SEMIS
+ (fig-forth-auto680):05473 *
+ (fig-forth-auto680):05474 * ======>> XX <<
+ (fig-forth-auto680):05475 * ( --- )
+ (fig-forth-auto680):05476 * Mostly for place holding (fig Forth).
+2A7C 84 (fig-forth-auto680):05477 FCB $84
+2A7D 4E4F4F (fig-forth-auto680):05478 FCC 'NOO' ; 'NOOP'
+2A80 D0 (fig-forth-auto680):05479 FCB $D0
+2A81 2A53 (fig-forth-auto680):05480 FDB BDUMP-8
+2A83 1228 (fig-forth-auto680):05481 NOOP FDB NEXT a useful no-op
+2A85 0000000000000000 (fig-forth-auto680):05482 ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
+ 0000000000000000
+ (fig-forth-auto680):05483
+ (fig-forth-auto680):05484 PAGE
+ (fig-forth-auto680):05485 * These things, up through the lable 'REND', are overwritten
+ (fig-forth-auto680):05486 * at time of cold load and should have the same contents
+ (fig-forth-auto680):05487 * as shown here:
+ (fig-forth-auto680):05488 *
+ (fig-forth-auto680):05489 * This can be moved whereever the bottom of the
+ (fig-forth-auto680):05490 * user's dictionary is going to be put.
+ (fig-forth-auto680):05491 *
+2A95 C5 (fig-forth-auto680):05492 FCB $C5 immediate
+2A96 464F5254 (fig-forth-auto680):05493 FCC 'FORT' ; 'FORTH'
+2A9A C8 (fig-forth-auto680):05494 FCB $C8
+2A9B 2A7C (fig-forth-auto680):05495 FDB NOOP-7
+2A9D 1C8621A181A02AC5 (fig-forth-auto680):05496 FORTH FDB DODOES,DOVOC,$81A0,TASK-7
+2AA5 0000 (fig-forth-auto680):05497 FDB 0
+ (fig-forth-auto680):05498 *
+2AA7 28432920466F7274 (fig-forth-auto680):05499 FCC "(C) Forth Interest Group, 1979"
+ 6820496E74657265
+ 73742047726F7570
+ 2C2031393739
+ (fig-forth-auto680):05500
+2AC5 84 (fig-forth-auto680):05501 FCB $84
+2AC6 544153 (fig-forth-auto680):05502 FCC 'TAS' ; 'TASK'
+2AC9 CB (fig-forth-auto680):05503 FCB $CB
+2ACA 2A95 (fig-forth-auto680):05504 FDB FORTH-8
+2ACC 17B91667 (fig-forth-auto680):05505 TASK FDB DOCOL,SEMIS
+ (fig-forth-auto680):05506 *
+ 2AD0 (fig-forth-auto680):05507 REND EQU * ( first empty location in dictionary )
+ (fig-forth-auto680):05508
+ (fig-forth-auto680):05509
+ (fig-forth-auto680):05510
+ (fig-forth-auto680):05511
+ (fig-forth-auto680):05512
+ (fig-forth-auto680):05513
+ (fig-forth-auto680):05514
+ (fig-forth-auto680):05515 PAGE
+ (fig-forth-auto680):05516 OPT L
+ (fig-forth-auto680):05517 END
--- /dev/null
+ (fig-forth-auto680):00001 OPT PRT
+ (fig-forth-auto680):00002
+ (fig-forth-auto680):00003 * fig-FORTH FOR 6809
+ (fig-forth-auto680):00004 * ASSEMBLY SOURCE LISTING
+ (fig-forth-auto680):00005
+ (fig-forth-auto680):00006 * RELEASE 0
+ (fig-forth-auto680):00007 * JAN 2019
+ (fig-forth-auto680):00008 * WITH COMPILER SECURITY
+ (fig-forth-auto680):00009 * AND VARIABLE LENGTH NAMES
+ (fig-forth-auto680):00010 *
+ (fig-forth-auto680):00011 * Adapted by Joel Matthew Rees
+ (fig-forth-auto680):00012 * from fig-FORTH for 6800 by Dave Lion, et. al.
+ (fig-forth-auto680):00013
+ (fig-forth-auto680):00014 * This free/libre/open source publication is provided
+ (fig-forth-auto680):00015 * through the courtesy of:
+ (fig-forth-auto680):00016 * FORTH
+ (fig-forth-auto680):00017 * INTEREST
+ (fig-forth-auto680):00018 * GROUP
+ (fig-forth-auto680):00019 * fig
+ (fig-forth-auto680):00020 * and other interested parties.
+ (fig-forth-auto680):00021
+ (fig-forth-auto680):00022 * Ancient address:
+ (fig-forth-auto680):00023 * P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
+ (fig-forth-auto680):00024 * URL: http://www.forth.org
+ (fig-forth-auto680):00025 * Further distribution must include this notice.
+ (fig-forth-auto680):00026 PAGE
+ (fig-forth-auto680):00027 NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
+ (fig-forth-auto680):00028 OPT NOG,PAG
+ (fig-forth-auto680):00029 * filename fig-forth-auto6809opt.asm
+ (fig-forth-auto680):00030 * === FORTH-6809 {date} {time}
+ (fig-forth-auto680):00031
+ (fig-forth-auto680):00032
+ (fig-forth-auto680):00033 * Permission is hereby granted, free of charge, to any person obtaining a copy
+ (fig-forth-auto680):00034 * of this software and associated documentation files (the "Software"), to deal
+ (fig-forth-auto680):00035 * in the Software without restriction, including without limitation the rights
+ (fig-forth-auto680):00036 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+ (fig-forth-auto680):00037 * copies of the Software, and to permit persons to whom the Software is
+ (fig-forth-auto680):00038 * furnished to do so, subject to the following conditions:
+ (fig-forth-auto680):00039 *
+ (fig-forth-auto680):00040 * The above copyright notice and this permission notice shall be included in
+ (fig-forth-auto680):00041 * all copies or substantial portions of the Software.
+ (fig-forth-auto680):00042
+ (fig-forth-auto680):00043 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ (fig-forth-auto680):00044 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ (fig-forth-auto680):00045 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+ (fig-forth-auto680):00046 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ (fig-forth-auto680):00047 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+ (fig-forth-auto680):00048 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+ (fig-forth-auto680):00049 * THE SOFTWARE.
+ (fig-forth-auto680):00050 *
+ (fig-forth-auto680):00051 * "Associated documentation" for this declaration of license
+ (fig-forth-auto680):00052 * shall be interpreted to include only the comments in this file,
+ (fig-forth-auto680):00053 * or, if the code is split into multiple files,
+ (fig-forth-auto680):00054 * all files containing the complete source.
+ (fig-forth-auto680):00055 *
+ (fig-forth-auto680):00056 * This is the MIT model license, as published by the Open Source Consortium,
+ (fig-forth-auto680):00057 * with associated documentation defined.
+ (fig-forth-auto680):00058 * It was chosen to reflect the spirit of the original
+ (fig-forth-auto680):00059 * terms of use, which used archaic legal terminology.
+ (fig-forth-auto680):00060 *
+ (fig-forth-auto680):00061
+ (fig-forth-auto680):00062 * Authors of the 6800 model:
+ (fig-forth-auto680):00063 * === Primary: Dave Lion,
+ (fig-forth-auto680):00064 * === with help from
+ (fig-forth-auto680):00065 * === Bob Smith,
+ (fig-forth-auto680):00066 * === LaFarr Stuart,
+ (fig-forth-auto680):00067 * === The Forth Interest Group
+ (fig-forth-auto680):00068 * === PO Box 1105
+ (fig-forth-auto680):00069 * === San Carlos, CA 94070
+ (fig-forth-auto680):00070 * === and
+ (fig-forth-auto680):00071 * === Unbounded Computing
+ (fig-forth-auto680):00072 * === 1134-K Aster Ave.
+ (fig-forth-auto680):00073 * === Sunnyvale, CA 94086
+ (fig-forth-auto680):00074 *
+ 0002 (fig-forth-auto680):00075 NATWID EQU 2 ; bytes per natural integer/pointer
+ (fig-forth-auto680):00076 * The original version was developed on an AMI EVK 300 PROTO
+ (fig-forth-auto680):00077 * system using an ACIA for the I/O.
+ (fig-forth-auto680):00078 * This version is developed targeting the Tandy Color Computer.
+ (fig-forth-auto680):00079
+ (fig-forth-auto680):00080 * All terminal 1/0
+ (fig-forth-auto680):00081 * is done in three subroutines:
+ (fig-forth-auto680):00082 * PEMIT ( word # 182 )
+ (fig-forth-auto680):00083 * PKEY ( 183 )
+ (fig-forth-auto680):00084 * PQTERM ( 184 )
+ (fig-forth-auto680):00085 *
+ (fig-forth-auto680):00086 * The FORTH words for disc related I/O follow the model
+ (fig-forth-auto680):00087 * of the FORTH Interest Group, but have not yet been
+ (fig-forth-auto680):00088 * tested using a real disc.
+ (fig-forth-auto680):00089 *
+ (fig-forth-auto680):00090 * Addresses in the 6800 implementation reflect the fact that,
+ (fig-forth-auto680):00091 * on the development system, it was convenient to
+ (fig-forth-auto680):00092 * write-protect memory at hex 1000, and leave the first
+ (fig-forth-auto680):00093 * 4K bytes write-enabled. As a consequence, code from
+ (fig-forth-auto680):00094 * location $1000 to lable ZZZZ could be put in ROM.
+ (fig-forth-auto680):00095 * Minor deviations from the model were made in the
+ (fig-forth-auto680):00096 * initialization and words ?STACK and FORGET
+ (fig-forth-auto680):00097 * in order to do this.
+ (fig-forth-auto680):00098 * Those deviations will be altered in this
+ (fig-forth-auto680):00099 * implementation for the 6809 -- Color Computer.
+ (fig-forth-auto680):00100 *
+ (fig-forth-auto680):00101
+ (fig-forth-auto680):00102 *
+ 7FFF (fig-forth-auto680):00103 MEMT32 EQU $7FFF absolute end of all ram
+ 3FFF (fig-forth-auto680):00104 MEMT16 EQU $3FFF
+ 7FFF (fig-forth-auto680):00105 MEMTOP EQU MEMT32 ; tentative guess
+ FBCE (fig-forth-auto680):00106 ACIAC EQU $FBCE the ACIA control address and
+ FBCF (fig-forth-auto680):00107 ACIAD EQU ACIAC+1 data address for PROTO
+ (fig-forth-auto680):00108 PAGE
+ (fig-forth-auto680):00109 * MEMORY MAP for this 16K|32K system:
+ (fig-forth-auto680):00110 * ( delineated so that systems with 4k byte write-
+ (fig-forth-auto680):00111 * protected segments can write protect FORTH )
+ (fig-forth-auto680):00112 *
+ (fig-forth-auto680):00113 * addr. contents pointer init by
+ (fig-forth-auto680):00114 * **** ******************************* ******* ******
+ (fig-forth-auto680):00115 * 2nd through 4th per-user tables
+ (fig-forth-auto680):00116 * 4000|7D00
+ 0100 (fig-forth-auto680):00117 USERSZ EQU 256 ; (Addressable by DP)
+ 0001 (fig-forth-auto680):00118 USER16 EQU 1 ; We can change these for ROMPACK or 64K.
+ 0004 (fig-forth-auto680):00119 USER32 EQU 4
+ 0004 (fig-forth-auto680):00120 USERCT EQU USER32
+ 3F00 (fig-forth-auto680):00121 IUP16 EQU MEMT16+1-USER16*USERSZ
+ 7C00 (fig-forth-auto680):00122 IUP32 EQU MEMT32+1-USER32*USERSZ
+ 7C00 (fig-forth-auto680):00123 IUP EQU IUP32
+ 007C (fig-forth-auto680):00124 IUPDP EQU IUP/256
+ (fig-forth-auto680):00125 * user tables of variables
+ (fig-forth-auto680):00126 * registers & pointers for the virtual machine
+ (fig-forth-auto680):00127 * scratch area used by various words
+ (fig-forth-auto680):00128 * 3F00|7C00 <== UP (DICTPT)
+ (fig-forth-auto680):00129 * 3EFF|7BFF HI
+ (fig-forth-auto680):00130 * substitute for disc mass memory
+ 0003 (fig-forth-auto680):00131 RAMSCR EQU 3
+ 0400 (fig-forth-auto680):00132 SCRSZ EQU 1024
+ (fig-forth-auto680):00133 * 3300|7000 LO,MEMEND
+ 3300 (fig-forth-auto680):00134 RAMD16 EQU IUP16-RAMSCR*SCRSZ
+ 7000 (fig-forth-auto680):00135 RAMD32 EQU IUP32-RAMSCR*SCRSZ
+ 7000 (fig-forth-auto680):00136 RAMDSK EQU RAMD32
+ 3300 (fig-forth-auto680):00137 MEME16 EQU RAMD16
+ 7000 (fig-forth-auto680):00138 MEME32 EQU RAMD32
+ 7000 (fig-forth-auto680):00139 MEMEND EQU MEME32
+ (fig-forth-auto680):00140 * 32FF|6FFF
+ (fig-forth-auto680):00141 * 4 buffer sectors of VIRTUAL MEMORY
+ 0004 (fig-forth-auto680):00142 NBLK EQU 4 ; # of disc buffer blocks for virtual memory
+ (fig-forth-auto680):00143 * Should NBLK be SCRSZ/SECTSZ?
+ (fig-forth-auto680):00144 * each block is SECTSZ+SECTRL bytes in size,
+ (fig-forth-auto680):00145 * holding SECTSZ characters
+ 0100 (fig-forth-auto680):00146 SECTSZ EQU 256
+ 0008 (fig-forth-auto680):00147 SECTRL EQU 8
+ 0420 (fig-forth-auto680):00148 BUFSZ EQU (SECTSZ+SECTRL)*NBLK
+ (fig-forth-auto680):00149 * 2EE0|6BE0 FIRST
+ 2EE0 (fig-forth-auto680):00150 BUFB16 EQU MEME16-BUFSZ
+ 6BE0 (fig-forth-auto680):00151 BUFB32 EQU MEME32-BUFSZ
+ 6BE0 (fig-forth-auto680):00152 BUFBAS EQU BUFB32
+ (fig-forth-auto680):00153 * "end" of "usable ram" -- in 16K
+ (fig-forth-auto680):00154 * 2EE0|6BE0 <== RP RINIT
+ 2EE0 (fig-forth-auto680):00155 IRP16 EQU BUFB16
+ 6BE0 (fig-forth-auto680):00156 IRP32 EQU BUFB32
+ 6BE0 (fig-forth-auto680):00157 IRP EQU IRP32
+ (fig-forth-auto680):00158 * RETURN STACK
+ (fig-forth-auto680):00159 * (64|112 levels nesting)
+ 0080 (fig-forth-auto680):00160 RSTK16 EQU 128
+ 00E0 (fig-forth-auto680):00161 RSTK32 EQU 224
+ (fig-forth-auto680):00162 * (2E60|6B00)
+ 2E60 (fig-forth-auto680):00163 SFTB16 EQU IRP16-RSTK16
+ 6B00 (fig-forth-auto680):00164 SFTB32 EQU IRP32-RSTK32
+ 6B00 (fig-forth-auto680):00165 SFTBND EQU SFTB32
+ (fig-forth-auto680):00166 * INPUT LINE BUFFER
+ (fig-forth-auto680):00167 * holds up to 256 characters
+ (fig-forth-auto680):00168 * and is scanned upward by IN
+ (fig-forth-auto680):00169 * starting at TIB
+ 0100 (fig-forth-auto680):00170 TIBSZ EQU 256
+ (fig-forth-auto680):00171 * 2D60|6A00
+ 2D60 (fig-forth-auto680):00172 ITIB16 EQU SFTB16-TIBSZ
+ 6A00 (fig-forth-auto680):00173 ITIB32 EQU SFTB32-TIBSZ
+ 6A00 (fig-forth-auto680):00174 ITIB EQU ITIB32
+ (fig-forth-auto680):00175 * 2D60|6A00 <== IN TIB
+ 2D60 (fig-forth-auto680):00176 ISP16 EQU ITIB16
+ 6A00 (fig-forth-auto680):00177 ISP32 EQU ITIB32
+ 6A00 (fig-forth-auto680):00178 ISP EQU ISP32
+ (fig-forth-auto680):00179 * 2D60|6A00 <== SP SP0,SINIT
+ (fig-forth-auto680):00180 * DATA STACK
+ (fig-forth-auto680):00181 * | grows downward from 2A60|6A00
+ (fig-forth-auto680):00182 * v
+ (fig-forth-auto680):00183 * - -
+ (fig-forth-auto680):00184 * |
+ (fig-forth-auto680):00185 * I DICTIONARY grows upward
+ (fig-forth-auto680):00186 *
+ (fig-forth-auto680):00187 * ???? end of ram-dictionary. <== DICTPT DPINIT
+ (fig-forth-auto680):00188 * "TASK"
+ (fig-forth-auto680):00189 *
+ (fig-forth-auto680):00190 * ???? "FORTH" ( a word ) <=, <== CONTEXT
+ (fig-forth-auto680):00191 * `==== CURRENT
+ (fig-forth-auto680):00192 * start of ram-dictionary.
+ (fig-forth-auto680):00193 *
+ (fig-forth-auto680):00194 * >>>>>> memory from here up must be in RAM area <<<<<<
+ (fig-forth-auto680):00195 *
+ (fig-forth-auto680):00196 * ????
+ (fig-forth-auto680):00197 * 6k of romable "FORTH" <== IP ABORT
+ (fig-forth-auto680):00198 * <== W
+ (fig-forth-auto680):00199 * the VIRTUAL FORTH MACHINE
+ (fig-forth-auto680):00200 *
+ (fig-forth-auto680):00201 * 1208 initialization tables
+ (fig-forth-auto680):00202 * 1204 <<< WARM START ENTRY >>>
+ (fig-forth-auto680):00203 * 1200 <<< COLD START ENTRY >>>
+ (fig-forth-auto680):00204 * 1200 lowest address used by FORTH
+ (fig-forth-auto680):00205 *
+ 1200 (fig-forth-auto680):00206 CODEBG EQU $1200
+ (fig-forth-auto680):00207 * CODEBG EQU $3000
+ (fig-forth-auto680):00208 *
+ (fig-forth-auto680):00209 * >>>>>> memory from here down left alone <<<<<<
+ (fig-forth-auto680):00210 * >>>>>> so we can safely call ROM routines <<<<<<
+ (fig-forth-auto680):00211 *
+ (fig-forth-auto680):00212 * 0000
+ (fig-forth-auto680):00213 PAGE
+ (fig-forth-auto680):00214 ***
+ (fig-forth-auto680):00215 *
+ (fig-forth-auto680):00216 * CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
+ (fig-forth-auto680):00217 *
+ (fig-forth-auto680):00218 * IP (hardware Y) points to the current instruction ( pre-increment mode )
+ (fig-forth-auto680):00219 * RP (hardware S) points to last return address pushedin return stack
+ (fig-forth-auto680):00220 * SP (hardware U) points to last byte pushed in data stack
+ (fig-forth-auto680):00221 *
+ (fig-forth-auto680):00222 * Y must be IP when NEXT is entered (if using the inner loop).
+ (fig-forth-auto680):00223 *
+ (fig-forth-auto680):00224 * When A and B hold one 16 bit FORTH data word,
+ (fig-forth-auto680):00225 * A contains the high byte, B, the low byte.
+ (fig-forth-auto680):00226 *
+ (fig-forth-auto680):00227 * UP (hardware DP) is the base of per-task ("user") variables.
+ (fig-forth-auto680):00228 * (Be careful of the stray semantics of "user".)
+ (fig-forth-auto680):00229 *
+ (fig-forth-auto680):00230 * W (hardware X) is the pointer to the "code field" address of native CPU
+ (fig-forth-auto680):00231 * machine code to be executed for the definition of the dictionary word
+ (fig-forth-auto680):00232 * to be executed/currently executing.
+ (fig-forth-auto680):00233 * The following natural integer (word) begins any "parameter section"
+ (fig-forth-auto680):00234 * (body) -- similar to a "this" pointer, but not the same.
+ (fig-forth-auto680):00235 * It may be native CPU machine code, or it may be a global variable,
+ (fig-forth-auto680):00236 * or it may be a list of Forth definition words (addresses).
+ (fig-forth-auto680):00237 *
+ (fig-forth-auto680):00238 * ======
+ (fig-forth-auto680):00239 * This implementation uses the native subroutine architecture
+ (fig-forth-auto680):00240 * rather than a postponed-push call that the 6800 model VM uses
+ (fig-forth-auto680):00241 * to save code and time in leaf routines.
+ (fig-forth-auto680):00242 *
+ (fig-forth-auto680):00243 * This should allow directly calling many of the Forth words
+ (fig-forth-auto680):00244 * from assembly language code.
+ (fig-forth-auto680):00245 * (Be aware of the need for a valid W in some cases.)
+ (fig-forth-auto680):00246 * It won't allow mixing assembly language directly into Forth word lists.
+ (fig-forth-auto680):00247 * ======
+ (fig-forth-auto680):00248 *
+ (fig-forth-auto680):00249 * boolean flags:
+ (fig-forth-auto680):00250 * 0 is false, anything else is true.
+ (fig-forth-auto680):00251 * Most places in this model that set a boolean flag set true as 1.
+ (fig-forth-auto680):00252 * This is in contrast to many models that set a boolean flag as -1.
+ (fig-forth-auto680):00253 *
+ (fig-forth-auto680):00254 ***
+ (fig-forth-auto680):00255
+ (fig-forth-auto680):00256 PAGE
+ (fig-forth-auto680):00257 * This system is shown with one user (task),
+ (fig-forth-auto680):00258 * but additional users (tasks) may be added
+ (fig-forth-auto680):00259 * by allocating additional user tables:
+ (fig-forth-auto680):00260 *
+ (fig-forth-auto680):00261 ORG IUP
+7C00 (fig-forth-auto680):00262 UBASE RMB USERSZ
+7D00 (fig-forth-auto680):00263 UBASEX RMB USERSZ data table for extra users
+ (fig-forth-auto680):00264 *
+ (fig-forth-auto680):00265 * Some of this stuff gets initialized during
+ (fig-forth-auto680):00266 * COLD start and WARM start:
+ (fig-forth-auto680):00267 * [ names correspond to FORTH words of similar (no X) name ]
+ (fig-forth-auto680):00268 *
+ (fig-forth-auto680):00269 ORG IUP
+ 7C00 (fig-forth-auto680):00270 UORIG EQU *
+ (fig-forth-auto680):00271 * A few useful VM variables
+ (fig-forth-auto680):00272 * Will be removed when they are no longer needed.
+ (fig-forth-auto680):00273 * All are replaced by 6809 registers.
+ (fig-forth-auto680):00274
+7C00 (fig-forth-auto680):00275 N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
+ (fig-forth-auto680):00276 * SP@,SWAP,DOES>,COLD
+ (fig-forth-auto680):00277
+ (fig-forth-auto680):00278
+ (fig-forth-auto680):00279 * These locations are used by the TRACE routine :
+ (fig-forth-auto680):00280
+7C0A (fig-forth-auto680):00281 TRLIM RMB 1 the count for tracing without user intervention
+7C0B (fig-forth-auto680):00282 TRACEM RMB 1 non-zero = trace mode
+7C0C (fig-forth-auto680):00283 BRKPT RMB 2 the breakpoint address at which
+ (fig-forth-auto680):00284 * the program will go into trace mode
+7C0E (fig-forth-auto680):00285 VECT RMB 2 vector to machine code
+ (fig-forth-auto680):00286 * (only needed if the TRACE routine is resident)
+ (fig-forth-auto680):00287
+ (fig-forth-auto680):00288
+ (fig-forth-auto680):00289 * Registers used by the FORTH virtual machine:
+ (fig-forth-auto680):00290 * Starting at $OOFO:
+ (fig-forth-auto680):00291
+ (fig-forth-auto680):00292
+7C10 (fig-forth-auto680):00293 W RMB 2 the instruction register points to 6800 code
+ (fig-forth-auto680):00294 * This is not exactly accurate. Points to the definiton body,
+ (fig-forth-auto680):00295 * which is native CPU machine code when it is native CPU machine code.
+7C12 (fig-forth-auto680):00296 IP RMB 2 the instruction pointer points to pointer to 6800 code
+7C14 (fig-forth-auto680):00297 RP RMB 2 the return stack pointer
+7C16 (fig-forth-auto680):00298 UP RMB 2 the pointer to base of current user's 'USER' table
+ (fig-forth-auto680):00299 * ( altered during multi-tasking )
+ (fig-forth-auto680):00300 *
+ (fig-forth-auto680):00301 *UORIG RMB 6 3 reserved variables
+7C18 (fig-forth-auto680):00302 RMB 6 3 reserved variables
+7C1E (fig-forth-auto680):00303 XSPZER RMB 2 initial top of data stack for this user
+7C20 (fig-forth-auto680):00304 XRZERO RMB 2 initial top of return stack
+7C22 (fig-forth-auto680):00305 XTIB RMB 2 start of terminal input buffer
+7C24 (fig-forth-auto680):00306 XWIDTH RMB 2 name field width
+7C26 (fig-forth-auto680):00307 XWARN RMB 2 warning message mode (0 = no disc)
+7C28 (fig-forth-auto680):00308 XFENCE RMB 2 fence for FORGET
+7C2A (fig-forth-auto680):00309 XDICTP RMB 2 dictionary pointer
+7C2C (fig-forth-auto680):00310 XVOCL RMB 2 vocabulary linking
+7C2E (fig-forth-auto680):00311 XBLK RMB 2 disc block being accessed
+7C30 (fig-forth-auto680):00312 XIN RMB 2 scan pointer into the block
+7C32 (fig-forth-auto680):00313 XOUT RMB 2 cursor position
+7C34 (fig-forth-auto680):00314 XSCR RMB 2 disc screen being accessed ( O=terminal )
+7C36 (fig-forth-auto680):00315 XOFSET RMB 2 disc sector offset for multi-disc
+7C38 (fig-forth-auto680):00316 XCONT RMB 2 last word in primary search vocabulary
+7C3A (fig-forth-auto680):00317 XCURR RMB 2 last word in extensible vocabulary
+7C3C (fig-forth-auto680):00318 XSTATE RMB 2 flag for 'interpret' or 'compile' modes
+7C3E (fig-forth-auto680):00319 XBASE RMB 2 number base for I/O numeric conversion
+7C40 (fig-forth-auto680):00320 XDPL RMB 2 decimal point place
+7C42 (fig-forth-auto680):00321 XFLD RMB 2
+7C44 (fig-forth-auto680):00322 XCSP RMB 2 current stack position, for compile checks
+7C46 (fig-forth-auto680):00323 XRNUM RMB 2
+7C48 (fig-forth-auto680):00324 XHLD RMB 2
+7C4A (fig-forth-auto680):00325 XDELAY RMB 2 carriage return delay count
+7C4C (fig-forth-auto680):00326 XCOLUM RMB 2 carriage width
+7C4E (fig-forth-auto680):00327 IOSTAT RMB 2 last acia status from write/read
+7C50 (fig-forth-auto680):00328 RMB 2 ( 4 spares! )
+7C52 (fig-forth-auto680):00329 RMB 2
+7C54 (fig-forth-auto680):00330 RMB 2
+7C56 (fig-forth-auto680):00331 RMB 2
+ (fig-forth-auto680):00332
+ (fig-forth-auto680):00333
+ (fig-forth-auto680):00334
+ (fig-forth-auto680):00335
+ (fig-forth-auto680):00336 *
+ (fig-forth-auto680):00337 *
+ (fig-forth-auto680):00338 * end of user table, start of common system variables
+ (fig-forth-auto680):00339 *
+ (fig-forth-auto680):00340 *
+ (fig-forth-auto680):00341 *
+7C58 (fig-forth-auto680):00342 XUSE RMB 2
+7C5A (fig-forth-auto680):00343 XPREV RMB 2
+7C5C (fig-forth-auto680):00344 RMB 4 ( spares )
+ (fig-forth-auto680):00345
+ (fig-forth-auto680):00346 PAGE
+ (fig-forth-auto680):00347 * The FORTH program ( address $1200 to about $27FF ) will be written
+ (fig-forth-auto680):00348 * so that it can be in a ROM, or write-protected if desired,
+ (fig-forth-auto680):00349 * but right now we're just getting it running.
+ (fig-forth-auto680):00350 ORG CODEBG
+ (fig-forth-auto680):00351
+ (fig-forth-auto680):00352 * ######>> screen 3 <<
+ (fig-forth-auto680):00353 *
+ (fig-forth-auto680):00354 ***************************
+ (fig-forth-auto680):00355 ** C O L D E N T R Y **
+ (fig-forth-auto680):00356 ***************************
+1200 12 (fig-forth-auto680):00357 ORIG NOP
+ (fig-forth-auto680):00358 * JMP CENT
+1201 171028 (fig-forth-auto680):00359 LBSR CENT
+ (fig-forth-auto680):00360 ***************************
+ (fig-forth-auto680):00361 ** W A R M E N T R Y **
+ (fig-forth-auto680):00362 ***************************
+1204 12 (fig-forth-auto680):00363 NOP
+ (fig-forth-auto680):00364 * JMP WENT warm-start code, keeps current dictionary intact
+1205 171061 (fig-forth-auto680):00365 LBSR WENT warm-start code, keeps current dictionary intact
+ 7C (fig-forth-auto680):00366 SETDP IUPDP
+ (fig-forth-auto680):00367
+ (fig-forth-auto680):00368 *
+ (fig-forth-auto680):00369 ******* startup parmeters **************************
+ (fig-forth-auto680):00370 *
+1208 68090000 (fig-forth-auto680):00371 FDB $6809,0000 cpu & revision
+120C 0000 (fig-forth-auto680):00372 FDB 0 topmost word in FORTH vocabulary
+ (fig-forth-auto680):00373 * BACKSP FDB $7F backspace character for editing
+120E 0008 (fig-forth-auto680):00374 BACKSP FDB $08 backspace character for editing
+1210 7C00 (fig-forth-auto680):00375 UPINIT FDB UORIG initial user area
+ (fig-forth-auto680):00376 * UPINIT FDB UORIG initial user area
+1212 6A00 (fig-forth-auto680):00377 SINIT FDB ISP ; initial top of data stack
+ (fig-forth-auto680):00378 * SINIT FDB ORIG-$D0 initial top of data stack
+1214 6BE0 (fig-forth-auto680):00379 RINIT FDB IRP ; initial top of return stack
+ (fig-forth-auto680):00380 * RINIT FDB ORIG-2 initial top of return stack
+1216 6A00 (fig-forth-auto680):00381 FDB ITIB ; terminal input buffer
+ (fig-forth-auto680):00382 * FDB ORIG-$D0 terminal input buffer
+1218 001F (fig-forth-auto680):00383 FDB 31 initial name field width
+121A 0000 (fig-forth-auto680):00384 FDB 0 initial warning mode (0 = no disc)
+121C 2A31 (fig-forth-auto680):00385 FENCIN FDB REND initial fence
+121E 2A31 (fig-forth-auto680):00386 DPINIT FDB REND cold start value for DICTPT
+1220 2A06 (fig-forth-auto680):00387 VOCINT FDB FORTH+4*NATWID
+1222 0084 (fig-forth-auto680):00388 COLINT FDB 132 initial terminal carriage width
+1224 0004 (fig-forth-auto680):00389 DELINT FDB 4 initial carriage return delay
+ (fig-forth-auto680):00390 ****************************************************
+ (fig-forth-auto680):00391 *
+ (fig-forth-auto680):00392 PAGE
+ (fig-forth-auto680):00393 *
+ (fig-forth-auto680):00394 * ######>> screen 13 <<
+ (fig-forth-auto680):00395 * These were of questionable use anyway,
+ (fig-forth-auto680):00396 * kept here now to satisfy the assembler and show hints.
+ (fig-forth-auto680):00397 * They're too much trouble to use with native subroutine call anyway.
+ (fig-forth-auto680):00398 * PULABX PULS A ; 24 cycles until 'NEXT'
+ (fig-forth-auto680):00399 * PULS B ;
+ (fig-forth-auto680):00400 * PULABX PULU A,B ; ?? cycles until 'NEXT'
+ (fig-forth-auto680):00401 * STABX STA 0,X 16 cycles until 'NEXT'
+ (fig-forth-auto680):00402 * STB 1,X
+ (fig-forth-auto680):00403 * STABX STD 0,X ; ?? cycles until 'NEXT'
+1226 2000 (fig-forth-auto680):00404 BRA NEXT
+ (fig-forth-auto680):00405 * GETX LDA 0,X 18 cycles until 'NEXT'
+ (fig-forth-auto680):00406 * LDB 1,X
+ (fig-forth-auto680):00407 * GETX LDD 0,X ?? cycles until 'NEXT'
+ (fig-forth-auto680):00408 * PUSHBA PSHS B ; 8 cycles until 'NEXT'
+ (fig-forth-auto680):00409 * PSHS A ;
+ (fig-forth-auto680):00410 * PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
+ (fig-forth-auto680):00411
+ (fig-forth-auto680):00412
+ (fig-forth-auto680):00413 *
+ (fig-forth-auto680):00414 * "NEXT" takes ?? cycles if TRACE is removed,
+ (fig-forth-auto680):00415 *
+ (fig-forth-auto680):00416 * and ?? cycles if trace is present and NOT tracing.
+ (fig-forth-auto680):00417 *
+ (fig-forth-auto680):00418 * = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
+ (fig-forth-auto680):00419 * =
+ (fig-forth-auto680):00420 * NEXT itself might just completely go away.
+ (fig-forth-auto680):00421 * About the only reason to keep it is to allowing executing a list
+ (fig-forth-auto680):00422 * which allows a cheap TRACE routine.
+ (fig-forth-auto680):00423 *
+ (fig-forth-auto680):00424 * NEXT is a loop which implements the Forth VM.
+ (fig-forth-auto680):00425 * It basically cycles through calling the code out of code lists,
+ (fig-forth-auto680):00426 * one at a time.
+ (fig-forth-auto680):00427 * Using a native CPU return for this uses a few extra cycles per call,
+ (fig-forth-auto680):00428 * compared to simply jumping to each definition and jumping back
+ (fig-forth-auto680):00429 * to the known beginning of the loop,
+ (fig-forth-auto680):00430 * but the loop itself is really only there for convenience.
+ (fig-forth-auto680):00431 *
+ (fig-forth-auto680):00432 * This implementation uses the native subroutine call,
+ (fig-forth-auto680):00433 * to break the wall between Forth code and non-Forth code.
+ (fig-forth-auto680):00434 *
+ (fig-forth-auto680):00435 * NEXT LDX IP
+ (fig-forth-auto680):00436 * LEAX 1,X ; pre-increment mode
+ (fig-forth-auto680):00437 * LEAX 1,X ;
+ (fig-forth-auto680):00438 * STX IP
+1228 (fig-forth-auto680):00439 NEXT ; IP is Y, push before using, pull before you come back here.
+ (fig-forth-auto680):00440 *
+ (fig-forth-auto680):00441 * NEXT2 LDX 0,X get W which points to CFA of word to be done
+1228 AEA1 (fig-forth-auto680):00442 NEXT2 LDX ,Y++ get W which points to CFA of word to be done
+122A 8D08 (fig-forth-auto680):00443 BSR DBGNAM
+122C 8D58 (fig-forth-auto680):00444 BSR DBGREG
+ (fig-forth-auto680):00445 * But NEXT2 is too much trouble to use with subroutine threading anyway.
+ (fig-forth-auto680):00446 * NEXT3 STX W
+122E (fig-forth-auto680):00447 NEXT3 ; W is X until you use X for something else. (TOS points back here.)
+ (fig-forth-auto680):00448 * But NEXT3 is too much trouble to use with subroutine threading anyway.
+ (fig-forth-auto680):00449 * LDX 0,X get VECT which points to executable code
+ (fig-forth-auto680):00450 * =
+ (fig-forth-auto680):00451 * The next instruction could be patched to JMP TRACE =
+ (fig-forth-auto680):00452 * if a TRACE routine is available: =
+ (fig-forth-auto680):00453 * =
+ (fig-forth-auto680):00454 * JMP 0,X
+ (fig-forth-auto680):00455
+122E AD94 (fig-forth-auto680):00456 JSR [,X] ; Saving the postinc cycles,
+ (fig-forth-auto680):00457 * ; but X must be bumped NATWID to the parameters.
+ (fig-forth-auto680):00458 * NOP
+ (fig-forth-auto680):00459 * JMP TRACE ( an alternate for the above )
+1230 8D54 (fig-forth-auto680):00460 BSR DBGREG ( an alternate for the above )
+ (fig-forth-auto680):00461 * In other words, with the call and the NOP,
+ (fig-forth-auto680):00462 * there is room to patch the call with a JMP to your TRACE
+ (fig-forth-auto680):00463 * routine, which you have to provide.
+1232 20F4 (fig-forth-auto680):00464 BRA NEXT
+ (fig-forth-auto680):00465 *
+1234 3437 (fig-forth-auto680):00466 DBGNAM PSHS CC,D,X,Y
+1236 0D0B (fig-forth-auto680):00467 TST <TRACEM
+1238 2724 (fig-forth-auto680):00468 BEQ DBGNrt
+123A 301D (fig-forth-auto680):00469 LEAX -3,X
+123C E682 (fig-forth-auto680):00470 DBGNlf LDB ,-X
+123E 2AFC (fig-forth-auto680):00471 BPL DBGNlf
+1240 108E04C0 (fig-forth-auto680):00472 LDY #$4C0
+1244 E680 (fig-forth-auto680):00473 LDB ,X+
+1246 E680 (fig-forth-auto680):00474 DBGNlp LDB ,X+
+1248 2B04 (fig-forth-auto680):00475 BMI DBGNll
+124A E7A0 (fig-forth-auto680):00476 STB ,Y+
+124C 20F8 (fig-forth-auto680):00477 BRA DBGNlp
+124E C47F (fig-forth-auto680):00478 DBGNll ANDB #$7F
+1250 E7A0 (fig-forth-auto680):00479 STB ,Y+
+1252 C660 (fig-forth-auto680):00480 LDB #$60
+1254 2002 (fig-forth-auto680):00481 BRA DBGNlt
+1256 E7A0 (fig-forth-auto680):00482 DBGNlc STB ,Y+
+1258 108C04E0 (fig-forth-auto680):00483 DBGNlt CMPY #$4E0
+125C 25F8 (fig-forth-auto680):00484 BLO DBGNlc
+125E 35B7 (fig-forth-auto680):00485 DBGNrt PULS CC,D,X,Y,PC
+ (fig-forth-auto680):00486 *
+ (fig-forth-auto680):00487 *
+1260 54 (fig-forth-auto680):00488 MKhxBh LSRB
+1261 54 (fig-forth-auto680):00489 LSRB
+1262 54 (fig-forth-auto680):00490 LSRB
+1263 54 (fig-forth-auto680):00491 LSRB
+1264 C40F (fig-forth-auto680):00492 MKhxBl ANDB #$0F
+1266 CB30 (fig-forth-auto680):00493 ADDB #$30
+1268 C139 (fig-forth-auto680):00494 CMPB #$39
+126A 2302 (fig-forth-auto680):00495 BLS MKhxBx
+126C CBC7 (fig-forth-auto680):00496 ADDB #$C7 ; ($40-$39)-$40
+126E 39 (fig-forth-auto680):00497 MKhxBx RTS
+ (fig-forth-auto680):00498 *
+126F 1E89 (fig-forth-auto680):00499 OUThxA EXG A,B
+1271 8D05 (fig-forth-auto680):00500 BSR OUThxB
+1273 1E89 (fig-forth-auto680):00501 EXG A,B
+1275 39 (fig-forth-auto680):00502 RTS
+ (fig-forth-auto680):00503 *
+1276 8DF7 (fig-forth-auto680):00504 OUThxD BSR OUThxA
+1278 3404 (fig-forth-auto680):00505 OUThxB PSHS B
+127A 8DE4 (fig-forth-auto680):00506 BSR MKhxBh
+127C E780 (fig-forth-auto680):00507 STB ,X+
+127E E6E4 (fig-forth-auto680):00508 LDB ,S
+1280 8DE2 (fig-forth-auto680):00509 BSR MKhxBl
+1282 E780 (fig-forth-auto680):00510 STB ,X+
+1284 3584 (fig-forth-auto680):00511 PULS B,PC
+ (fig-forth-auto680):00512 *
+1286 347F (fig-forth-auto680):00513 DBGREG PSHS U,Y,X,DP,B,A,CC
+1288 0D0B (fig-forth-auto680):00514 TST <TRACEM
+128A 102700DF (fig-forth-auto680):00515 LBEQ DBGRrt
+128E 318D00DD (fig-forth-auto680):00516 LEAY DBGRLB,PCR
+1292 8E04E0 (fig-forth-auto680):00517 LDX #$4E0
+1295 ECA1 (fig-forth-auto680):00518 DBGRlp LDD ,Y++
+1297 2704 (fig-forth-auto680):00519 BEQ DBGRdn
+1299 ED81 (fig-forth-auto680):00520 STD ,X++
+129B 20F8 (fig-forth-auto680):00521 BRA DBGRlp
+129D 8E0500 (fig-forth-auto680):00522 DBGRdn LDX #$500
+12A0 A663 (fig-forth-auto680):00523 LDA 3,S ; DP
+12A2 E6E4 (fig-forth-auto680):00524 LDB ,S ; CC
+12A4 8DD0 (fig-forth-auto680):00525 BSR OUThxD
+12A6 C660 (fig-forth-auto680):00526 LDB #$60
+12A8 E780 (fig-forth-auto680):00527 STB ,X+
+12AA EC6A (fig-forth-auto680):00528 LDD 3*NATWID+4,S ; PC:505
+12AC 8DC8 (fig-forth-auto680):00529 BSR OUThxD
+12AE C660 (fig-forth-auto680):00530 LDB #$60
+12B0 E780 (fig-forth-auto680):00531 STB ,X+
+12B2 1F40 (fig-forth-auto680):00532 TFR S,D ; 509
+12B4 C3000C (fig-forth-auto680):00533 ADDD #4*NATWID+4
+12B7 8DBD (fig-forth-auto680):00534 BSR OUThxD
+12B9 EC68 (fig-forth-auto680):00535 LDD 2*NATWID+4,S ; U:50E
+12BB 8DB9 (fig-forth-auto680):00536 BSR OUThxD
+12BD C660 (fig-forth-auto680):00537 LDB #$60
+12BF E780 (fig-forth-auto680):00538 STB ,X+
+12C1 EC66 (fig-forth-auto680):00539 LDD 1*NATWID+4,S ; Y:513
+12C3 8DB1 (fig-forth-auto680):00540 BSR OUThxD
+12C5 EC64 (fig-forth-auto680):00541 LDD 0*NATWID+4,S ; X at 517
+12C7 8DAD (fig-forth-auto680):00542 BSR OUThxD
+12C9 C660 (fig-forth-auto680):00543 LDB #$60
+12CB E780 (fig-forth-auto680):00544 STB ,X+
+12CD EC61 (fig-forth-auto680):00545 LDD 1,S ; D at 51C
+12CF 8DA5 (fig-forth-auto680):00546 BSR OUThxD
+12D1 C660 (fig-forth-auto680):00547 LDB #$60
+12D3 E780 (fig-forth-auto680):00548 STB ,X+
+12D5 E780 (fig-forth-auto680):00549 STB ,X+
+12D7 E780 (fig-forth-auto680):00550 STB ,X+
+12D9 E780 (fig-forth-auto680):00551 STB ,X+
+12DB E780 (fig-forth-auto680):00552 STB ,X+
+12DD ECF80A (fig-forth-auto680):00553 LDD [3*NATWID+4,S] ; PC
+12E0 8D94 (fig-forth-auto680):00554 BSR OUThxD
+12E2 C660 (fig-forth-auto680):00555 LDB #$60
+12E4 E780 (fig-forth-auto680):00556 STB ,X+
+12E6 EC6C (fig-forth-auto680):00557 LDD 4*NATWID+4,S ; S
+12E8 8D8C (fig-forth-auto680):00558 BSR OUThxD
+12EA ECF808 (fig-forth-auto680):00559 LDD [2*NATWID+4,S] ; U
+12ED 8D87 (fig-forth-auto680):00560 BSR OUThxD
+12EF C660 (fig-forth-auto680):00561 LDB #$60
+12F1 E780 (fig-forth-auto680):00562 STB ,X+
+12F3 ECF806 (fig-forth-auto680):00563 LDD [1*NATWID+4,S] ; Y
+12F6 17FF7D (fig-forth-auto680):00564 LBSR OUThxD
+12F9 ECF804 (fig-forth-auto680):00565 LDD [0*NATWID+4,S] ; X
+12FC 17FF77 (fig-forth-auto680):00566 LBSR OUThxD
+12FF C660 (fig-forth-auto680):00567 LDB #$60
+1301 E780 (fig-forth-auto680):00568 STB ,X+
+1303 E780 (fig-forth-auto680):00569 STB ,X+
+1305 E780 (fig-forth-auto680):00570 STB ,X+
+1307 E780 (fig-forth-auto680):00571 STB ,X+
+1309 E780 (fig-forth-auto680):00572 STB ,X+
+130B C600 (fig-forth-auto680):00573 LDB #0
+130D 1E9B (fig-forth-auto680):00574 EXG B,DP
+130F AD9FA000 (fig-forth-auto680):00575 DBGRkl JSR [$A000]
+1313 27FA (fig-forth-auto680):00576 BEQ DBGRkl
+1315 FD043E (fig-forth-auto680):00577 STD $43E
+1318 1EB9 (fig-forth-auto680):00578 EXG DP,B
+131A 8155 (fig-forth-auto680):00579 CMPA #$55 ; 'U'
+131C 273C (fig-forth-auto680):00580 BEQ DBGRdU
+131E 8153 (fig-forth-auto680):00581 CMPA #$53 ; 'S'
+1320 271E (fig-forth-auto680):00582 BEQ DBGRdS
+1322 8149 (fig-forth-auto680):00583 CMPA #$49 ; 'I'
+1324 2647 (fig-forth-auto680):00584 BNE DBGRrt
+1326 DC22 (fig-forth-auto680):00585 DBGRin LDD <XTIB
+1328 D330 (fig-forth-auto680):00586 ADDD <XIN
+132A 1F02 (fig-forth-auto680):00587 TFR D,Y
+132C 17FF47 (fig-forth-auto680):00588 LBSR OUThxD
+132F C63A (fig-forth-auto680):00589 LDB #$3a ; ':'
+1331 E780 (fig-forth-auto680):00590 STB ,X+
+1333 964C (fig-forth-auto680):00591 LDA <XCOLUM
+1335 E6A0 (fig-forth-auto680):00592 DBGRip LDB ,Y+
+1337 E780 (fig-forth-auto680):00593 STB ,X+
+1339 2732 (fig-forth-auto680):00594 BEQ DBGRrt
+133B 4A (fig-forth-auto680):00595 DBGRit DECA
+133C 26F7 (fig-forth-auto680):00596 BNE DBGRip
+133E 202D (fig-forth-auto680):00597 BRA DBGRrt
+1340 1F42 (fig-forth-auto680):00598 DBGRdS TFR S,Y
+1342 2009 (fig-forth-auto680):00599 BRA DBGRst
+1344 ECA1 (fig-forth-auto680):00600 DBGRsp LDD ,Y++
+1346 17FF2D (fig-forth-auto680):00601 LBSR OUThxD
+1349 C660 (fig-forth-auto680):00602 LDB #$60
+134B E780 (fig-forth-auto680):00603 STB ,X+
+134D 109C20 (fig-forth-auto680):00604 DBGRst CMPY <XRZERO
+1350 25F2 (fig-forth-auto680):00605 BLO DBGRsp
+1352 C63A (fig-forth-auto680):00606 LDB #$3a ; ':'
+1354 E780 (fig-forth-auto680):00607 STB ,X+
+1356 C655 (fig-forth-auto680):00608 LDB #$55
+1358 E780 (fig-forth-auto680):00609 STB ,X+
+135A 10AE68 (fig-forth-auto680):00610 DBGRdU LDY 2*NATWID+4,S
+135D 2009 (fig-forth-auto680):00611 BRA DBGRut
+135F ECA1 (fig-forth-auto680):00612 DBGRup LDD ,Y++
+1361 17FF12 (fig-forth-auto680):00613 LBSR OUThxD
+1364 C660 (fig-forth-auto680):00614 LDB #$60
+1366 E780 (fig-forth-auto680):00615 STB ,X+
+1368 109C1E (fig-forth-auto680):00616 DBGRut CMPY <XSPZER
+136B 25F2 (fig-forth-auto680):00617 BLO DBGRup
+136D 35FF (fig-forth-auto680):00618 DBGRrt PULS CC,A,B,DP,X,Y,U,PC
+136F 4450434320504320 (fig-forth-auto680):00619 DBGRLB FCC 'DPCC PC S U Y X A B '
+ 2020532020205520
+ 2020205920202058
+ 2020202041204220
+138F 00000000 (fig-forth-auto680):00620 FDB 0,0
+ (fig-forth-auto680):00621
+ (fig-forth-auto680):00622
+ (fig-forth-auto680):00623 *
+ (fig-forth-auto680):00624 * =
+ (fig-forth-auto680):00625 * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+ (fig-forth-auto680):00626
+ (fig-forth-auto680):00627
+ (fig-forth-auto680):00628 PAGE
+ (fig-forth-auto680):00629 *
+ (fig-forth-auto680):00630 * ======>> 1 <<
+ (fig-forth-auto680):00631 * ( --- n )
+ (fig-forth-auto680):00632 * Pushes the following natural width integer from the instruction stream
+ (fig-forth-auto680):00633 * as a literal, or immediate value.
+ (fig-forth-auto680):00634 *
+ (fig-forth-auto680):00635 * FDB {OP}
+ (fig-forth-auto680):00636 * FDB {OP}
+ (fig-forth-auto680):00637 * FDB LIT
+ (fig-forth-auto680):00638 * FDB LITERAL-TO-BE-PUSHED
+ (fig-forth-auto680):00639 * FDB {OP}
+ (fig-forth-auto680):00640 *
+ (fig-forth-auto680):00641 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00642 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00643 * (Note that there is no compile-only flag in the fig model.)
+ (fig-forth-auto680):00644 *
+ (fig-forth-auto680):00645 * See (FIND), or PFIND , for layout of the header format.
+ (fig-forth-auto680):00646 *
+1393 83 (fig-forth-auto680):00647 FCB $83
+1394 4C49 (fig-forth-auto680):00648 FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
+1396 D4 (fig-forth-auto680):00649 FCB $D4 ; 'T'|'\x80' ; character code for T, with high bit set.
+1397 0000 (fig-forth-auto680):00650 FDB 0 ; link of zero to terminate dictionary scan
+1399 139B (fig-forth-auto680):00651 LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
+139B ECA1 (fig-forth-auto680):00652 LDD ,Y++
+139D 3606 (fig-forth-auto680):00653 PSHU A,B
+139F 39 (fig-forth-auto680):00654 RTS
+ (fig-forth-auto680):00655 * LDX IP
+ (fig-forth-auto680):00656 * LEAX 1,X ;
+ (fig-forth-auto680):00657 * LEAX 1,X ;
+ (fig-forth-auto680):00658 * STX IP
+ (fig-forth-auto680):00659 * LDA 0,X
+ (fig-forth-auto680):00660 * LDB 1,X
+ (fig-forth-auto680):00661 * JMP PUSHBA
+ (fig-forth-auto680):00662 *
+ (fig-forth-auto680):00663 * ######>> screen 14 <<
+ (fig-forth-auto680):00664 * ======>> 2 <<
+ (fig-forth-auto680):00665 * ( --- n )
+ (fig-forth-auto680):00666 * Pushes the following byte from the instruction stream
+ (fig-forth-auto680):00667 * as a literal, or immediate value.
+ (fig-forth-auto680):00668 *
+ (fig-forth-auto680):00669 * FDB {OP}
+ (fig-forth-auto680):00670 * FDB {OP}
+ (fig-forth-auto680):00671 * FDB LIT8
+ (fig-forth-auto680):00672 * FCB LITERAL-TO-BE-PUSHED
+ (fig-forth-auto680):00673 * FDB {OP}
+ (fig-forth-auto680):00674 *
+ (fig-forth-auto680):00675 * If this is kept, it should have a header for TRACE to read.
+ (fig-forth-auto680):00676 * If the data bus is wider than a byte, you don't want to do this.
+ (fig-forth-auto680):00677 * Byte shaving like this is often counter-productive anyway.
+ (fig-forth-auto680):00678 * Changing the name to LIT8, hoping that will be more understandable.
+ (fig-forth-auto680):00679 * Also, see comments for LIT.
+ (fig-forth-auto680):00680 * (Note that there is no compile-only flag in the fig model.)
+13A0 84 (fig-forth-auto680):00681 FCB $84
+13A1 4C4954 (fig-forth-auto680):00682 FCC 'LIT' ; 'LIT8' : NOTE: this is different from LITERAL
+13A4 B8 (fig-forth-auto680):00683 FCB $B8
+13A5 1393 (fig-forth-auto680):00684 FDB LIT-6
+13A7 13A9 (fig-forth-auto680):00685 LIT8 FDB *+NATWID (this was an invisible word, with no header)
+13A9 E6A0 (fig-forth-auto680):00686 LDB ,Y+ ; This also is meaningless in native code.
+13AB 4F (fig-forth-auto680):00687 CLRA
+13AC 3606 (fig-forth-auto680):00688 PSHU A,B
+13AE 39 (fig-forth-auto680):00689 RTS
+ (fig-forth-auto680):00690 * LDX IP
+ (fig-forth-auto680):00691 * LEAX 1,X ;
+ (fig-forth-auto680):00692 * STX IP
+ (fig-forth-auto680):00693 * CLRA ;
+ (fig-forth-auto680):00694 * LDB 1,X
+ (fig-forth-auto680):00695 * JMP PUSHBA
+ (fig-forth-auto680):00696 *
+ (fig-forth-auto680):00697 * ( n off --- n )
+ (fig-forth-auto680):00698 * off is offset in video buffer area.
+13AF 87 (fig-forth-auto680):00699 FCB $87
+13B0 53484F57544F (fig-forth-auto680):00700 FCC 'SHOWTO' ; 'SHOWTOS'
+13B6 D3 (fig-forth-auto680):00701 FCB $D3 ; 'S'
+13B7 13A0 (fig-forth-auto680):00702 FDB LIT8-7
+13B9 13BB (fig-forth-auto680):00703 SHOTOS FDB *+NATWID
+13BB 8E0400 (fig-forth-auto680):00704 LDX #$400
+13BE ECC1 (fig-forth-auto680):00705 LDD ,U++
+13C0 308B (fig-forth-auto680):00706 LEAX D,X
+13C2 ECC4 (fig-forth-auto680):00707 LDD ,U
+13C4 17FEAF (fig-forth-auto680):00708 LBSR OUThxD
+13C7 39 (fig-forth-auto680):00709 RTS
+ (fig-forth-auto680):00710 *
+13C8 85 (fig-forth-auto680):00711 FCB $85
+13C9 54524F46 (fig-forth-auto680):00712 FCC 'TROF' ; 'TROFF'
+13CD C6 (fig-forth-auto680):00713 FCB $C6 ; 'F'|$80
+13CE 13AF (fig-forth-auto680):00714 FDB SHOTOS-10
+13D0 13D2 (fig-forth-auto680):00715 TROFF FDB *+NATWID
+13D2 0F0B (fig-forth-auto680):00716 CLR <TRACEM
+13D4 39 (fig-forth-auto680):00717 RTS
+ (fig-forth-auto680):00718 *
+13D5 84 (fig-forth-auto680):00719 FCB $84
+13D6 54524F (fig-forth-auto680):00720 FCC 'TRO' ; 'TRON'
+13D9 CE (fig-forth-auto680):00721 FCB $CE ; 'N'|$80
+13DA 13C8 (fig-forth-auto680):00722 FDB TROFF-8
+13DC 13DE (fig-forth-auto680):00723 TRON FDB *+NATWID
+13DE 0C0B (fig-forth-auto680):00724 INC <TRACEM
+13E0 39 (fig-forth-auto680):00725 RTS
+ (fig-forth-auto680):00726 *
+ (fig-forth-auto680):00727 * ======>> 3 <<
+ (fig-forth-auto680):00728 * ( adr --- )
+ (fig-forth-auto680):00729 * Jump to address on stack. Used by the "outer" interpreter to
+ (fig-forth-auto680):00730 * interactively invoke routines.
+ (fig-forth-auto680):00731 * Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
+13E1 87 (fig-forth-auto680):00732 FCB $87
+13E2 455845435554 (fig-forth-auto680):00733 FCC 'EXECUT' ; 'EXECUTE'
+13E8 C5 (fig-forth-auto680):00734 FCB $C5
+13E9 13D5 (fig-forth-auto680):00735 FDB TRON-7
+13EB 13ED (fig-forth-auto680):00736 EXEC FDB *+NATWID
+13ED 3710 (fig-forth-auto680):00737 PULU X ; Gotta have W anyway, just in case.
+13EF 6E94 (fig-forth-auto680):00738 JMP [,X] ; Tail return.
+ (fig-forth-auto680):00739 * TFR S,X ; TSX :
+ (fig-forth-auto680):00740 * LDX 0,X get code field address (CFA)
+ (fig-forth-auto680):00741 * LEAS 1,S ; pop stack
+ (fig-forth-auto680):00742 * LEAS 1,S ;
+ (fig-forth-auto680):00743 * JMP NEXT3
+ (fig-forth-auto680):00744 *
+ (fig-forth-auto680):00745 * ######>> screen 15 <<
+ (fig-forth-auto680):00746 * ======>> 4 <<
+ (fig-forth-auto680):00747 * ( --- ) C
+ (fig-forth-auto680):00748 * Add the following word from the instruction stream to the
+ (fig-forth-auto680):00749 * instruction pointer (Y++). Causes a program branch in Forth code stream.
+ (fig-forth-auto680):00750 *
+ (fig-forth-auto680):00751 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00752 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00753 * This is only for Forth code stream.
+ (fig-forth-auto680):00754 * Also, see comments for LIT.
+13F1 86 (fig-forth-auto680):00755 FCB $86
+13F2 4252414E43 (fig-forth-auto680):00756 FCC 'BRANC' ; 'BRANCH'
+13F7 C8 (fig-forth-auto680):00757 FCB $C8
+13F8 13E1 (fig-forth-auto680):00758 FDB EXEC-10
+13FA 140F (fig-forth-auto680):00759 BRAN FDB ZBYES ; Go steal code in ZBRANCH
+ (fig-forth-auto680):00760
+ (fig-forth-auto680):00761 * Moving code around to optimize the branch taking case in 0BRANCH.
+13FC 3122 (fig-forth-auto680):00762 ZBNO LEAY NATWID,Y ; No branch.
+13FE 39 (fig-forth-auto680):00763 RTS
+ (fig-forth-auto680):00764 * ======>> 5 <<
+ (fig-forth-auto680):00765 * ( f --- ) C
+ (fig-forth-auto680):00766 * BRANCH if flag is zero.
+ (fig-forth-auto680):00767 *
+ (fig-forth-auto680):00768 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00769 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00770 * This is only for Forth code stream.
+ (fig-forth-auto680):00771 * Also, see comments for LIT.
+13FF 87 (fig-forth-auto680):00772 FCB $87
+1400 304252414E43 (fig-forth-auto680):00773 FCC '0BRANC' ; '0BRANCH'
+1406 C8 (fig-forth-auto680):00774 FCB $C8
+1407 13F1 (fig-forth-auto680):00775 FDB BRAN-9
+1409 140B (fig-forth-auto680):00776 ZBRAN FDB *+NATWID
+140B ECC1 (fig-forth-auto680):00777 LDD ,U++
+140D 26ED (fig-forth-auto680):00778 BNE ZBNO
+140F ECA1 (fig-forth-auto680):00779 ZBYES LDD ,Y++
+1411 31AB (fig-forth-auto680):00780 LEAY D,Y ; IP is postinc
+1413 39 (fig-forth-auto680):00781 RTS
+ (fig-forth-auto680):00782 * PULS A ;
+ (fig-forth-auto680):00783 * PULS B ;
+ (fig-forth-auto680):00784 * PSHS B ; ** emulating ABA:
+ (fig-forth-auto680):00785 * ADDA ,S+ ;
+ (fig-forth-auto680):00786 * BNE ZBNO
+ (fig-forth-auto680):00787 * BCS ZBNO
+ (fig-forth-auto680):00788 * ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
+ (fig-forth-auto680):00789 * LDB 3,X
+ (fig-forth-auto680):00790 * LDA 2,X
+ (fig-forth-auto680):00791 * ADDB IP+1
+ (fig-forth-auto680):00792 * ADCA IP
+ (fig-forth-auto680):00793 * STB IP+1
+ (fig-forth-auto680):00794 * STA IP
+ (fig-forth-auto680):00795 * JMP NEXT
+ (fig-forth-auto680):00796 * ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
+ (fig-forth-auto680):00797 * LEAX 1,X ; jump over branch delta
+ (fig-forth-auto680):00798 * LEAX 1,X ;
+ (fig-forth-auto680):00799 * STX IP
+ (fig-forth-auto680):00800 * JMP NEXT
+ (fig-forth-auto680):00801 *
+ (fig-forth-auto680):00802 * ######>> screen 16 <<
+ (fig-forth-auto680):00803 * ======>> 6 <<
+ (fig-forth-auto680):00804 * ( --- ) ( limit index *** limit index+1) C
+ (fig-forth-auto680):00805 * ( limit index *** )
+ (fig-forth-auto680):00806 * Counting loop primitive. The counter and limit are the top two
+ (fig-forth-auto680):00807 * words on the return stack. If the updated index/counter does
+ (fig-forth-auto680):00808 * not exceed the limit, a branch occurs. If it does, the branch
+ (fig-forth-auto680):00809 * does not occur, and the index and limit are dropped from the
+ (fig-forth-auto680):00810 * return stack.
+ (fig-forth-auto680):00811 *
+ (fig-forth-auto680):00812 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00813 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00814 * This is only for Forth code stream.
+ (fig-forth-auto680):00815 * Also, see comments for LIT.
+1414 86 (fig-forth-auto680):00816 FCB $86
+1415 284C4F4F50 (fig-forth-auto680):00817 FCC '(LOOP' ; '(LOOP)'
+141A A9 (fig-forth-auto680):00818 FCB $A9
+141B 13FF (fig-forth-auto680):00819 FDB ZBRAN-10
+141D 141F (fig-forth-auto680):00820 XLOOP FDB *+NATWID
+141F CC0001 (fig-forth-auto680):00821 LDD #1 ; Borrowing from BIF-6809.
+1422 E362 (fig-forth-auto680):00822 XLOOPA ADDD NATWID,S ; Dodge the return address.
+1424 ED62 (fig-forth-auto680):00823 STD NATWID,S
+1426 A364 (fig-forth-auto680):00824 SUBD 2*NATWID,S
+1428 2DE5 (fig-forth-auto680):00825 BLT ZBYES ; signed
+142A 3122 (fig-forth-auto680):00826 XLOOPN LEAY NATWID,Y
+142C AEE4 (fig-forth-auto680):00827 LDX ,S ; synthetic return
+142E 3266 (fig-forth-auto680):00828 LEAS 3*NATWID,S ; Clean up the index and limit.
+1430 6E84 (fig-forth-auto680):00829 JMP ,X
+ (fig-forth-auto680):00830 * CLRA ;
+ (fig-forth-auto680):00831 * LDB #1 get set to increment counter by 1 (Clears N.)
+ (fig-forth-auto680):00832 * BRA XPLOP2 go steal other guy's code!
+ (fig-forth-auto680):00833 *
+ (fig-forth-auto680):00834 * ======>> 7 <<
+ (fig-forth-auto680):00835 * ( n --- ) ( limit index *** limit index+n ) C
+ (fig-forth-auto680):00836 * ( limit index *** )
+ (fig-forth-auto680):00837 * Loop with a variable increment. Terminates when the index
+ (fig-forth-auto680):00838 * crosses the boundary from one below the limit to the limit. A
+ (fig-forth-auto680):00839 * positive n will cause termination if the result index equals the
+ (fig-forth-auto680):00840 * limit. A negative n must cause the index to become less than
+ (fig-forth-auto680):00841 * the limit to cause loop termination.
+ (fig-forth-auto680):00842 *
+ (fig-forth-auto680):00843 * Note that the end conditions are not symmetric around zero.
+ (fig-forth-auto680):00844 *
+ (fig-forth-auto680):00845 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00846 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00847 * This is only for Forth code stream.
+ (fig-forth-auto680):00848 * Also, see comments for LIT.
+1432 87 (fig-forth-auto680):00849 FCB $87
+1433 282B4C4F4F50 (fig-forth-auto680):00850 FCC '(+LOOP' ; '(+LOOP)'
+1439 A9 (fig-forth-auto680):00851 FCB $A9
+143A 1414 (fig-forth-auto680):00852 FDB XLOOP-9
+143C 143E (fig-forth-auto680):00853 XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
+143E ECC1 (fig-forth-auto680):00854 LDD ,U++ ; inc val
+1440 2AE0 (fig-forth-auto680):00855 BPL XLOOPA ; Steal plain loop code for forward count.
+1442 E362 (fig-forth-auto680):00856 ADDD NATWID,S ; Dodge the return address
+1444 ED62 (fig-forth-auto680):00857 STD NATWID,S
+1446 A364 (fig-forth-auto680):00858 SUBD 2*NATWID,S
+1448 2EC5 (fig-forth-auto680):00859 BGT ZBYES ; signed
+144A 20DE (fig-forth-auto680):00860 BRA XLOOPN ; This path is less time-sensitive.
+ (fig-forth-auto680):00861 *
+ (fig-forth-auto680):00862 * This should work, but I want to use tested code.
+ (fig-forth-auto680):00863 * PULU A,B ; Get the increment.
+ (fig-forth-auto680):00864 * XPLOP2 PULS X ; Pre-clear the return stack.
+ (fig-forth-auto680):00865 * PSHU A ; Save the direction in high bit.
+ (fig-forth-auto680):00866 * ADDD ,S ; Count.
+ (fig-forth-auto680):00867 * STD ,S ; Update.
+ (fig-forth-auto680):00868 * SUBD NATWID,S ; Check limit.
+ (fig-forth-auto680):00869 **
+ (fig-forth-auto680):00870 ** I think this should work:
+ (fig-forth-auto680):00871 * EORA ,U+ ; dir < 0 and (count - limit) >= 0
+ (fig-forth-auto680):00872 * BPL XPLONO ; or dir >= 0 and (count - limit) < 0
+ (fig-forth-auto680):00873 * LDD ,Y++
+ (fig-forth-auto680):00874 * LEAY D,Y ; IP is postinc
+ (fig-forth-auto680):00875 * JMP ,X
+ (fig-forth-auto680):00876 * XPLONO LEAS 2*NATWID,S
+ (fig-forth-auto680):00877 * JMP ,X ; synthetic return
+ (fig-forth-auto680):00878 *
+ (fig-forth-auto680):00879 * This definitely should work:
+ (fig-forth-auto680):00880 * TST ,U+ ; Get the sign
+ (fig-forth-auto680):00881 * BPL XPLOF ;
+ (fig-forth-auto680):00882 * CMPD NATWID,S
+ (fig-forth-auto680):00883 * BMI XPLONO
+ (fig-forth-auto680):00884 * XPLOYE LDD ,Y++
+ (fig-forth-auto680):00885 * LEAY D,Y ; IP is postinc
+ (fig-forth-auto680):00886 * JMP ,X
+ (fig-forth-auto680):00887 * XPLOF CMPD NATWID,S
+ (fig-forth-auto680):00888 * BMI XPLOYE
+ (fig-forth-auto680):00889 * XPLONO LEAS 2*NATWID,S
+ (fig-forth-auto680):00890 * JMP ,X ; synthetic return
+ (fig-forth-auto680):00891 *
+ (fig-forth-auto680):00892 * 6800 Probably could have used the exclusive-or method, too.:
+ (fig-forth-auto680):00893 * PULS A ; get increment
+ (fig-forth-auto680):00894 * PULS B ;
+ (fig-forth-auto680):00895 * XPLOP2 TSTA ;
+ (fig-forth-auto680):00896 * BPL XPLOF forward looping
+ (fig-forth-auto680):00897 * BSR XPLOPS
+ (fig-forth-auto680):00898 * ORCC #$01 ; SEC :
+ (fig-forth-auto680):00899 * SBCB 5,X
+ (fig-forth-auto680):00900 * SBCA 4,X
+ (fig-forth-auto680):00901 * BPL ZBYES
+ (fig-forth-auto680):00902 * BRA XPLONO fall through
+ (fig-forth-auto680):00903 *
+ (fig-forth-auto680):00904 * the subroutine :
+ (fig-forth-auto680):00905 * XPLOPS LDX RP
+ (fig-forth-auto680):00906 * ADDB 3,X add it to counter
+ (fig-forth-auto680):00907 * ADCA 2,X
+ (fig-forth-auto680):00908 * STB 3,X store new counter value
+ (fig-forth-auto680):00909 * STA 2,X
+ (fig-forth-auto680):00910 * RTS
+ (fig-forth-auto680):00911 *
+ (fig-forth-auto680):00912 * XPLOF BSR XPLOPS
+ (fig-forth-auto680):00913 * SUBB 5,X
+ (fig-forth-auto680):00914 * SBCA 4,X
+ (fig-forth-auto680):00915 * BMI ZBYES
+ (fig-forth-auto680):00916 *
+ (fig-forth-auto680):00917 * XPLONO LEAX 1,X ; done, don't branch back
+ (fig-forth-auto680):00918 * LEAX 1,X ;
+ (fig-forth-auto680):00919 * LEAX 1,X ;
+ (fig-forth-auto680):00920 * LEAX 1,X ;
+ (fig-forth-auto680):00921 * STX RP
+ (fig-forth-auto680):00922 * BRA ZBNO use ZBRAN to skip over unused delta
+ (fig-forth-auto680):00923 *
+ (fig-forth-auto680):00924 * ######>> screen 17 <<
+ (fig-forth-auto680):00925 * ======>> 8 <<
+ (fig-forth-auto680):00926 * ( limit index --- ) ( *** limit index )
+ (fig-forth-auto680):00927 * Move the loop parameters to the return stack. Synonym for D>R.
+144C 84 (fig-forth-auto680):00928 FCB $84
+144D 28444F (fig-forth-auto680):00929 FCC '(DO' ; '(DO)'
+1450 A9 (fig-forth-auto680):00930 FCB $A9
+1451 1432 (fig-forth-auto680):00931 FDB XPLOOP-10
+1453 1455 (fig-forth-auto680):00932 XDO FDB *+NATWID This is the RUNTIME DO, not the COMPILING DO
+1455 AEE4 (fig-forth-auto680):00933 LDX ,S ; Save the return address.
+1457 3706 (fig-forth-auto680):00934 PULU A,B
+1459 3406 (fig-forth-auto680):00935 PSHS A,B
+145B 3706 (fig-forth-auto680):00936 PULU A,B ; Maintain order.
+145D ED62 (fig-forth-auto680):00937 STD NATWID,S
+145F 6E84 (fig-forth-auto680):00938 JMP ,X ; synthetic return
+ (fig-forth-auto680):00939 *
+ (fig-forth-auto680):00940 * LDX RP
+ (fig-forth-auto680):00941 * LEAX -1,X ;
+ (fig-forth-auto680):00942 * LEAX -1,X ;
+ (fig-forth-auto680):00943 * LEAX -1,X ;
+ (fig-forth-auto680):00944 * LEAX -1,X ;
+ (fig-forth-auto680):00945 * STX RP
+ (fig-forth-auto680):00946 * PULS A ;
+ (fig-forth-auto680):00947 * PULS B ;
+ (fig-forth-auto680):00948 * STA 2,X
+ (fig-forth-auto680):00949 * STB 3,X
+ (fig-forth-auto680):00950 * PULS A ;
+ (fig-forth-auto680):00951 * PULS B ;
+ (fig-forth-auto680):00952 * STA 4,X
+ (fig-forth-auto680):00953 * STB 5,X
+ (fig-forth-auto680):00954 * JMP NEXT
+ (fig-forth-auto680):00955 *
+ (fig-forth-auto680):00956 * ======>> 9 <<
+ (fig-forth-auto680):00957 * ( --- index ) ( limit index *** limit index )
+ (fig-forth-auto680):00958 * Copy the loop index from the return stack. Synonym for R.
+1461 81 (fig-forth-auto680):00959 FCB $81 I
+1462 C9 (fig-forth-auto680):00960 FCB $C9
+1463 144C (fig-forth-auto680):00961 FDB XDO-7
+1465 1467 (fig-forth-auto680):00962 I FDB *+NATWID
+1467 EC62 (fig-forth-auto680):00963 LDD NATWID,S ; Dodge return address.
+1469 3606 (fig-forth-auto680):00964 PSHU A,B
+146B 39 (fig-forth-auto680):00965 RTS
+ (fig-forth-auto680):00966 * LDX RP
+ (fig-forth-auto680):00967 * LEAX 1,X ;
+ (fig-forth-auto680):00968 * LEAX 1,X ;
+ (fig-forth-auto680):00969 * JMP GETX
+ (fig-forth-auto680):00970 *
+ (fig-forth-auto680):00971 * ######>> screen 18 <<
+ (fig-forth-auto680):00972 * ======>> 10 <<
+ (fig-forth-auto680):00973 * ( c base --- false )
+ (fig-forth-auto680):00974 * ( c base --- n true )
+ (fig-forth-auto680):00975 * Translate C in base, yielding a translation valid flag. If the
+ (fig-forth-auto680):00976 * translation is not valid in the specified base, only the false
+ (fig-forth-auto680):00977 * flag is returned.
+146C 85 (fig-forth-auto680):00978 FCB $85
+146D 44494749 (fig-forth-auto680):00979 FCC 'DIGI' ; 'DIGIT'
+1471 D4 (fig-forth-auto680):00980 FCB $D4
+1472 1461 (fig-forth-auto680):00981 FDB I-4
+1474 1476 (fig-forth-auto680):00982 DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
+1476 EC42 (fig-forth-auto680):00983 LDD NATWID,U ; Check the whole thing.
+1478 830030 (fig-forth-auto680):00984 SUBD #$30 ; ascii zero
+147B 2B22 (fig-forth-auto680):00985 BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+147D 1083000A (fig-forth-auto680):00986 CMPD #$A
+1481 2B0F (fig-forth-auto680):00987 BMI DIGIT0 IF '9' OR LESS
+1483 10830011 (fig-forth-auto680):00988 CMPD #$11
+1487 2B16 (fig-forth-auto680):00989 BMI DIGIT2 if less than 'A'
+1489 1083002B (fig-forth-auto680):00990 CMPD #$2B
+148D 2A10 (fig-forth-auto680):00991 BPL DIGIT2 if greater than 'Z'
+148F 830007 (fig-forth-auto680):00992 SUBD #7 translate 'A' thru 'F'
+1492 10A3C4 (fig-forth-auto680):00993 DIGIT0 CMPD ,U ; Check the base.
+1495 2A08 (fig-forth-auto680):00994 BPL DIGIT2 if not less than the base
+1497 ED42 (fig-forth-auto680):00995 STD NATWID,U ; Store converted digit. (High byte known zero.)
+1499 CC0001 (fig-forth-auto680):00996 LDD #1 ; set valid flag
+149C EDC4 (fig-forth-auto680):00997 DIGIT1 STD ,U ; store the flag
+149E 39 (fig-forth-auto680):00998 RTS NEXT
+149F CC0000 (fig-forth-auto680):00999 DIGIT2 LDD #0 ; set not valid flag
+14A2 3342 (fig-forth-auto680):01000 LEAU NATWID,U ; pop base
+14A4 20F6 (fig-forth-auto680):01001 BRA DIGIT1
+ (fig-forth-auto680):01002 * TFR S,X ; TSX :
+ (fig-forth-auto680):01003 * LDA 3,X
+ (fig-forth-auto680):01004 * SUBA #$30 ascii zero
+ (fig-forth-auto680):01005 * BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+ (fig-forth-auto680):01006 * CMPA #$A
+ (fig-forth-auto680):01007 * BMI DIGIT0 IF '9' OR LESS
+ (fig-forth-auto680):01008 * CMPA #$11
+ (fig-forth-auto680):01009 * BMI DIGIT2 if less than 'A'
+ (fig-forth-auto680):01010 * CMPA #$2B
+ (fig-forth-auto680):01011 * BPL DIGIT2 if greater than 'Z'
+ (fig-forth-auto680):01012 * SUBA #7 translate 'A' thru 'F'
+ (fig-forth-auto680):01013 * DIGIT0 CMPA 1,X
+ (fig-forth-auto680):01014 * BPL DIGIT2 if not less than the base
+ (fig-forth-auto680):01015 * LDB #1 set flag
+ (fig-forth-auto680):01016 * STA 3,X store digit
+ (fig-forth-auto680):01017 * DIGIT1 STB 1,X store the flag
+ (fig-forth-auto680):01018 * JMP NEXT
+ (fig-forth-auto680):01019 * DIGIT2 CLRB ;
+ (fig-forth-auto680):01020 * LEAS 1,S ;
+ (fig-forth-auto680):01021 * LEAS 1,S ; pop bottom number
+ (fig-forth-auto680):01022 * TFR S,X ; TSX :
+ (fig-forth-auto680):01023 * STB 0,X make sure both bytes are 00
+ (fig-forth-auto680):01024 * BRA DIGIT1
+ (fig-forth-auto680):01025 *
+ (fig-forth-auto680):01026 * ######>> screen 19 <<
+ (fig-forth-auto680):01027 *
+ (fig-forth-auto680):01028 * The word definition format in the dictionary:
+ (fig-forth-auto680):01029 *
+ (fig-forth-auto680):01030 * (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
+ (fig-forth-auto680):01031 *
+ (fig-forth-auto680):01032 * NFA (name field address):
+ (fig-forth-auto680):01033 * char-count + $80 Length of symbol name, flagged with high bit set.
+ (fig-forth-auto680):01034 * char 1 Characters of symbol name.
+ (fig-forth-auto680):01035 * char 2
+ (fig-forth-auto680):01036 * ...
+ (fig-forth-auto680):01037 * char n + $80 symbol termination flag (char set < 128 code points)
+ (fig-forth-auto680):01038 * LFA (link field address):
+ (fig-forth-auto680):01039 * link high byte \___pointer to previous word in list
+ (fig-forth-auto680):01040 * link low byte / -- Combined allocation/dictionary list. --
+ (fig-forth-auto680):01041 * CFA (code field address):
+ (fig-forth-auto680):01042 * CFA high byte \___pointer to native CPU machine code
+ (fig-forth-auto680):01043 * CFA low byte / -- Consider this the characteristic code. --
+ (fig-forth-auto680):01044 * PFA (parameter field address):
+ (fig-forth-auto680):01045 * parameter fields -- Machine code for low-level native machine CPU code,
+ (fig-forth-auto680):01046 * " instruction list for high-level Forth code,
+ (fig-forth-auto680):01047 * " constant data for constants, pointers to per task variables,
+ (fig-forth-auto680):01048 * " space for variables, for global variables, etc.
+ (fig-forth-auto680):01049 *
+ (fig-forth-auto680):01050 * In the case of native CPU machine code, the address at CFA will be PFA.
+ (fig-forth-auto680):01051
+ (fig-forth-auto680):01052 * Definition attributes:
+ 0040 (fig-forth-auto680):01053 FIMMED EQU $40 ; Immediate word flag.
+ 0020 (fig-forth-auto680):01054 FSMUDG EQU $20 ; Smudged => definition not ready.
+ 003F (fig-forth-auto680):01055 CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte.
+ (fig-forth-auto680):01056 * Note that the SMUDGE bit is not masked out.
+ (fig-forth-auto680):01057 *
+ (fig-forth-auto680):01058 * But we really want more (Thinking for a new model, need one more byte):
+ (fig-forth-auto680):01059 * FCOMPI EQU $10 ; Compile-time-only.
+ (fig-forth-auto680):01060 * FASSEM EQU $08 ; Assembly-language code only.
+ (fig-forth-auto680):01061 * F4THLV EQU $04 ; Must not be called from assembly language code.
+ (fig-forth-auto680):01062 * These would require some significant adjustments to the model.
+ (fig-forth-auto680):01063 * We also want to put the low-level VM stuff in its own vocabulary.
+ (fig-forth-auto680):01064 *
+ (fig-forth-auto680):01065 * ======>> 11 <<
+ (fig-forth-auto680):01066 * (FIND) ( name vocptr --- locptr length true )
+ (fig-forth-auto680):01067 * ( name vocptr --- false )
+ (fig-forth-auto680):01068 * Search vocabulary for a symbol called name.
+ (fig-forth-auto680):01069 * name is a pointer to a high-bit bracket string with length head.
+ (fig-forth-auto680):01070 * vocptr is a pointer to the NFA of the tail-end (LATEST) definition
+ (fig-forth-auto680):01071 * in the vocabulary to be searched.
+ (fig-forth-auto680):01072 * Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
+14A6 86 (fig-forth-auto680):01073 FCB $86
+14A7 2846494E44 (fig-forth-auto680):01074 FCC '(FIND' ; '(FIND)'
+14AC A9 (fig-forth-auto680):01075 FCB $A9
+14AD 146C (fig-forth-auto680):01076 FDB DIGIT-8
+14AF 14B1 (fig-forth-auto680):01077 PFIND FDB *+NATWID
+14B1 3420 (fig-forth-auto680):01078 PSHS Y ; Have to track two pointers.
+ (fig-forth-auto680):01079 * Use the stack and registers instead of temp area N.
+ 0002 (fig-forth-auto680):01080 PA0 EQU NATWID ; pointer to the length byte of name being searched against
+ 0000 (fig-forth-auto680):01081 PD EQU 0 ; pointer to NFA of dict word being checked
+ (fig-forth-auto680):01082 *
+14B3 AEC4 (fig-forth-auto680):01083 LDX PD,U ; Start in on the vocabulary (NFA).
+14B5 10AE42 (fig-forth-auto680):01084 PFNDLP LDY PA0,U ; Point to the name to check against.
+14B8 E680 (fig-forth-auto680):01085 LDB ,X+ ; get dict name length byte
+14BA 1F98 (fig-forth-auto680):01086 TFR B,A ; Save it in case it matches.
+14BC C43F (fig-forth-auto680):01087 ANDB #CTMASK
+14BE E1A0 (fig-forth-auto680):01088 CMPB ,Y+ ; Compare lengths
+14C0 261C (fig-forth-auto680):01089 BNE PFNDUN
+14C2 E680 (fig-forth-auto680):01090 PFNDBR LDB ,X+
+14C4 5D (fig-forth-auto680):01091 TSTB ; ; Is high bit of character in dictionary entry set?
+14C5 2A13 (fig-forth-auto680):01092 BPL PFNDCH
+14C7 C47F (fig-forth-auto680):01093 ANDB #$7F ; Clear high bit from dictionary.
+14C9 E1A0 (fig-forth-auto680):01094 CMPB ,Y+ ; Compare "last" characters.
+14CB 2717 (fig-forth-auto680):01095 BEQ FOUND ; Matches even if dictionary actual length is shorter.
+14CD AE81 (fig-forth-auto680):01096 PFNDLN LDX ,X++ ; Get previous link in vocabulary.
+14CF 26E4 (fig-forth-auto680):01097 BNE PFNDLP ; Continue if link not=0
+ (fig-forth-auto680):01098 *
+ (fig-forth-auto680):01099 * not found :
+14D1 3342 (fig-forth-auto680):01100 LEAU NATWID,U ; Return only false flag.
+14D3 CC0000 (fig-forth-auto680):01101 LDD #0
+14D6 EDC4 (fig-forth-auto680):01102 STD ,U
+14D8 35A0 (fig-forth-auto680):01103 PULS Y,PC
+ (fig-forth-auto680):01104 *
+14DA E1A0 (fig-forth-auto680):01105 PFNDCH CMPB ,Y+ ; Compare characters.
+14DC 27E4 (fig-forth-auto680):01106 BEQ PFNDBR
+14DE (fig-forth-auto680):01107 PFNDUN
+14DE E680 (fig-forth-auto680):01108 PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
+14E0 2AFC (fig-forth-auto680):01109 BPL PFNDSC
+14E2 20E9 (fig-forth-auto680):01110 BRA PFNDLN
+ (fig-forth-auto680):01111 *
+ (fig-forth-auto680):01112 * found :
+ (fig-forth-auto680):01113 *
+14E4 3004 (fig-forth-auto680):01114 FOUND LEAX 2*NATWID,X
+14E6 AF42 (fig-forth-auto680):01115 STX NATWID,U
+14E8 1F89 (fig-forth-auto680):01116 TFR A,B
+14EA 4F (fig-forth-auto680):01117 CLRA
+14EB EDC4 (fig-forth-auto680):01118 STD ,U
+14ED C601 (fig-forth-auto680):01119 LDB #1
+14EF 3606 (fig-forth-auto680):01120 PSHU A,B
+14F1 35A0 (fig-forth-auto680):01121 PULS Y,PC
+ (fig-forth-auto680):01122 *
+ (fig-forth-auto680):01123 * 6800 model:
+ (fig-forth-auto680):01124 * NOP ; Probably leftovers from a debugging session.
+ (fig-forth-auto680):01125 * NOP
+ (fig-forth-auto680):01126 * PD EQU N ptr to dict word being checked
+ (fig-forth-auto680):01127 * PA0 EQU N+2
+ (fig-forth-auto680):01128 * PA EQU N+4
+ (fig-forth-auto680):01129 * PC EQU N+6
+ (fig-forth-auto680):01130 * LDX #PD
+ (fig-forth-auto680):01131 * LDB #4
+ (fig-forth-auto680):01132 * PFIND0 PULS A ; loop to get arguments
+ (fig-forth-auto680):01133 * STA 0,X
+ (fig-forth-auto680):01134 * LEAX 1,X ;
+ (fig-forth-auto680):01135 * DECB ;
+ (fig-forth-auto680):01136 * BNE PFIND0
+ (fig-forth-auto680):01137 *
+ (fig-forth-auto680):01138 * LDX PD
+ (fig-forth-auto680):01139 * PFNDLP LDB 0,X get count dict count
+ (fig-forth-auto680):01140 * STB PC
+ (fig-forth-auto680):01141 * ANDB #$3F
+ (fig-forth-auto680):01142 * LEAX 1,X ;
+ (fig-forth-auto680):01143 * STX PD update PD
+ (fig-forth-auto680):01144 * LDX PA0
+ (fig-forth-auto680):01145 * LDA 0,X get count from arg
+ (fig-forth-auto680):01146 * LEAX 1,X ;
+ (fig-forth-auto680):01147 * STX PA intialize PA
+ (fig-forth-auto680):01148 * PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01149 * CMPA ,S+ ; compare lengths
+ (fig-forth-auto680):01150 * BNE PFNDUN
+ (fig-forth-auto680):01151 * PFNDBR LDX PA
+ (fig-forth-auto680):01152 * LDA 0,X
+ (fig-forth-auto680):01153 * LEAX 1,X ;
+ (fig-forth-auto680):01154 * STX PA
+ (fig-forth-auto680):01155 * LDX PD
+ (fig-forth-auto680):01156 * LDB 0,X
+ (fig-forth-auto680):01157 * LEAX 1,X ;
+ (fig-forth-auto680):01158 * STX PD
+ (fig-forth-auto680):01159 * TSTB ; is dict entry neg. ?
+ (fig-forth-auto680):01160 * BPL PFNDCH
+ (fig-forth-auto680):01161 * ANDB #$7F clear sign
+ (fig-forth-auto680):01162 * PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01163 * CMPA ,S+ ;
+ (fig-forth-auto680):01164 * BEQ FOUND
+ (fig-forth-auto680):01165 * PFNDLN LDX 0,X get new link
+ (fig-forth-auto680):01166 * BNE PFNDLP continue if link not=0
+ (fig-forth-auto680):01167 *
+ (fig-forth-auto680):01168 * not found :
+ (fig-forth-auto680):01169 *
+ (fig-forth-auto680):01170 * CLRA ;
+ (fig-forth-auto680):01171 * CLRB ;
+ (fig-forth-auto680):01172 * JMP PUSHBA
+ (fig-forth-auto680):01173 * PFNDCH PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01174 * CMPA ,S+ ;
+ (fig-forth-auto680):01175 * BEQ PFNDBR
+ (fig-forth-auto680):01176 * PFNDUN LDX PD
+ (fig-forth-auto680):01177 * PFNDSC LDB 0,X scan forward to end of this name
+ (fig-forth-auto680):01178 * LEAX 1,X ;
+ (fig-forth-auto680):01179 * BPL PFNDSC
+ (fig-forth-auto680):01180 * BRA PFNDLN
+ (fig-forth-auto680):01181 *
+ (fig-forth-auto680):01182 * found :
+ (fig-forth-auto680):01183 *
+ (fig-forth-auto680):01184 * FOUND LDA PD compute CFA
+ (fig-forth-auto680):01185 * LDB PD+1
+ (fig-forth-auto680):01186 * ADDB #4
+ (fig-forth-auto680):01187 * ADCA #0
+ (fig-forth-auto680):01188 * PSHS B ;
+ (fig-forth-auto680):01189 * PSHS A ;
+ (fig-forth-auto680):01190 * LDA PC
+ (fig-forth-auto680):01191 * PSHS A ;
+ (fig-forth-auto680):01192 * CLRA ;
+ (fig-forth-auto680):01193 * PSHS A ;
+ (fig-forth-auto680):01194 * LDB #1
+ (fig-forth-auto680):01195 * JMP PUSHBA
+ (fig-forth-auto680):01196 *
+ (fig-forth-auto680):01197 * PSHS A ; Left over from a stray copy-paste, I guess.
+ (fig-forth-auto680):01198 * CLRA ;
+ (fig-forth-auto680):01199 * PSHS A ;
+ (fig-forth-auto680):01200 * LDB #1
+ (fig-forth-auto680):01201 * JMP PUSHBA
+ (fig-forth-auto680):01202 *
+ (fig-forth-auto680):01203 * ######>> screen 20 <<
+ (fig-forth-auto680):01204 * ======>> 12 <<
+ (fig-forth-auto680):01205 * ( buffer ch --- buffer symboloffset delimiteroffset scancount )
+ (fig-forth-auto680):01206 * ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
+ (fig-forth-auto680):01207 * ( buffer ch --- buffer nuloffset onepast scancount )
+ (fig-forth-auto680):01208 * Scan buffer for a symbol delimited by ch or ASCII NUL,
+ (fig-forth-auto680):01209 * return the length of the buffer region scanned,
+ (fig-forth-auto680):01210 * the offset to the trailing delimiter,
+ (fig-forth-auto680):01211 * and the offset of the first character of the symbol.
+ (fig-forth-auto680):01212 * Leave the buffer on the stack.
+ (fig-forth-auto680):01213 * Scancount is also offset to first character not yet looked at.
+ (fig-forth-auto680):01214 * If no symbol in buffer, scancount and symboloffset point to NUL
+ (fig-forth-auto680):01215 * and delimiteroffset points one beyond for some reason.
+ (fig-forth-auto680):01216 * On trailing NUL, delimiteroffset == scancount.
+ (fig-forth-auto680):01217 * (Buffer is the address of the buffer array to scan.)
+ (fig-forth-auto680):01218 * (This is a bit too tricky, really.)
+14F3 87 (fig-forth-auto680):01219 FCB $87
+14F4 454E434C4F53 (fig-forth-auto680):01220 FCC 'ENCLOS' ; 'ENCLOSE'
+14FA C5 (fig-forth-auto680):01221 FCB $C5
+14FB 14A6 (fig-forth-auto680):01222 FDB PFIND-9
+14FD 14FF (fig-forth-auto680):01223 ENCLOS FDB *+NATWID
+14FF A641 (fig-forth-auto680):01224 LDA 1,U ; Delimiter character to match against in A.
+1501 AE42 (fig-forth-auto680):01225 LDX NATWID,U ; Buffer to scan in.
+1503 5F (fig-forth-auto680):01226 CLRB ; Initialize offset. (Buffer < 256 wide!)
+ (fig-forth-auto680):01227 * Scan to a non-delimiter or a NUL
+1504 6D85 (fig-forth-auto680):01228 ENCDEL TST B,X ; NUL ?
+1506 271F (fig-forth-auto680):01229 BEQ ENCNUL
+1508 A185 (fig-forth-auto680):01230 CMPA B,X ; Delimiter?
+150A 2603 (fig-forth-auto680):01231 BNE ENC1ST
+150C 5C (fig-forth-auto680):01232 INCB ; count character
+150D 20F5 (fig-forth-auto680):01233 BRA ENCDEL
+ (fig-forth-auto680):01234 * Found first character. Save the offset.
+150F E741 (fig-forth-auto680):01235 ENC1ST STB 1,U ; Found first non-delimiter character --
+1511 6FC4 (fig-forth-auto680):01236 CLR ,U ; store the count, zero high byte.
+ (fig-forth-auto680):01237 * Scan to a delimiter or a NUL
+1513 6D85 (fig-forth-auto680):01238 ENCSYM TST B,X ; NUL ?
+1515 271E (fig-forth-auto680):01239 BEQ ENC0TR
+1517 A185 (fig-forth-auto680):01240 CMPA B,X ; delimiter?
+1519 2703 (fig-forth-auto680):01241 BEQ ENCEND
+151B 5C (fig-forth-auto680):01242 INCB
+151C 20F5 (fig-forth-auto680):01243 BRA ENCSYM
+ (fig-forth-auto680):01244 * Found end of symbol. Push offset to delimiter found.
+151E 4F (fig-forth-auto680):01245 ENCEND CLRA ; high byte -- buffer < 255 wide!
+151F 3606 (fig-forth-auto680):01246 PSHU A,B ; Offset to seen delimiter.
+ (fig-forth-auto680):01247 * Advance and push address of next character to check.
+1521 C30001 (fig-forth-auto680):01248 ADDD #1 ; In case offset was 255.
+1524 3606 (fig-forth-auto680):01249 PSHU A,B
+1526 39 (fig-forth-auto680):01250 RTS
+ (fig-forth-auto680):01251 * Found NUL before non-delimiter, therefore there is no word
+1527 4F (fig-forth-auto680):01252 ENCNUL CLRA ; high byte -- buffer < 255 wide!
+1528 EDC4 (fig-forth-auto680):01253 STD ,U ; offset to NUL.
+152A C30001 (fig-forth-auto680):01254 ADDD #1 ; For some reason, point after NUL.
+152D 3606 (fig-forth-auto680):01255 PSHU A,B ;
+152F 830001 (fig-forth-auto680):01256 SUBD #1 ; Next is not passed NUL.
+1532 3606 (fig-forth-auto680):01257 PSHU A,B ; Stealing code will save only one byte.
+1534 39 (fig-forth-auto680):01258 RTS
+ (fig-forth-auto680):01259 * Found NUL following the word instead of delimiter.
+1535 3606 (fig-forth-auto680):01260 ENC0TR PSHU A,B ; Save offset to first after symbol (NUL)
+1537 3606 (fig-forth-auto680):01261 PSHU A,B ; and count scanned.
+1539 39 (fig-forth-auto680):01262 RTS
+ (fig-forth-auto680):01263 * NOTE :
+ (fig-forth-auto680):01264 * FC means offset (bytes) to First Character of next word
+ (fig-forth-auto680):01265 * EW " " to End of Word
+ (fig-forth-auto680):01266 * NC " " to Next Character to start next enclose at
+ (fig-forth-auto680):01267 * ENCLOS FDB *+NATWID
+ (fig-forth-auto680):01268 * LEAS 1,S ;
+ (fig-forth-auto680):01269 * PULS B ; now, get the low byte, for an 8-bit delimiter
+ (fig-forth-auto680):01270 * TFR S,X ; TSX :
+ (fig-forth-auto680):01271 * LDX 0,X
+ (fig-forth-auto680):01272 * CLR N
+ (fig-forth-auto680):01273 * * wait for a non-delimiter or a NUL
+ (fig-forth-auto680):01274 * ENCDEL LDA 0,X
+ (fig-forth-auto680):01275 * BEQ ENCNUL
+ (fig-forth-auto680):01276 * PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01277 * CMPA ,S+ ; CHECK FOR DELIM
+ (fig-forth-auto680):01278 * BNE ENC1ST
+ (fig-forth-auto680):01279 * LEAX 1,X ;
+ (fig-forth-auto680):01280 * INC N
+ (fig-forth-auto680):01281 * BRA ENCDEL
+ (fig-forth-auto680):01282 * * found first character. Push FC
+ (fig-forth-auto680):01283 * ENC1ST LDA N found first char.
+ (fig-forth-auto680):01284 * PSHS A ;
+ (fig-forth-auto680):01285 * CLRA ;
+ (fig-forth-auto680):01286 * PSHS A ;
+ (fig-forth-auto680):01287 * wait for a delimiter or a NUL
+ (fig-forth-auto680):01288 * ENCSYM LDA 0,X
+ (fig-forth-auto680):01289 * BEQ ENC0TR
+ (fig-forth-auto680):01290 * PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01291 * CMPA ,S+ ; ckech for delim.
+ (fig-forth-auto680):01292 * BEQ ENCEND
+ (fig-forth-auto680):01293 * LEAX 1,X ;
+ (fig-forth-auto680):01294 * INC N
+ (fig-forth-auto680):01295 * BRA ENCSYM
+ (fig-forth-auto680):01296 * * found EW. Push it
+ (fig-forth-auto680):01297 * ENCEND LDB N
+ (fig-forth-auto680):01298 * CLRA ;
+ (fig-forth-auto680):01299 * PSHS B ;
+ (fig-forth-auto680):01300 * PSHS A ;
+ (fig-forth-auto680):01301 * * advance and push NC
+ (fig-forth-auto680):01302 * INCB ;
+ (fig-forth-auto680):01303 * JMP PUSHBA
+ (fig-forth-auto680):01304 * found NUL before non-delimiter, therefore there is no word
+ (fig-forth-auto680):01305 * ENCNUL LDB N found NUL
+ (fig-forth-auto680):01306 * PSHS B ;
+ (fig-forth-auto680):01307 * PSHS A ;
+ (fig-forth-auto680):01308 * INCB ;
+ (fig-forth-auto680):01309 * BRA ENC0TR+2 ; ********** POTENTIAL BUG HERE *******
+ (fig-forth-auto680):01310 * ******** Should use labels in case opcodes change! ********
+ (fig-forth-auto680):01311 * found NUL following the word instead of SPACE
+ (fig-forth-auto680):01312 * ENC0TR LDB N
+ (fig-forth-auto680):01313 * PSHS B ; save EW
+ (fig-forth-auto680):01314 * PSHS A ;
+ (fig-forth-auto680):01315 * ENCL8 LDB N save NC
+ (fig-forth-auto680):01316 * JMP PUSHBA
+ (fig-forth-auto680):01317
+ (fig-forth-auto680):01318 PAGE
+ (fig-forth-auto680):01319 *
+ (fig-forth-auto680):01320 * ######>> screen 21 <<
+ (fig-forth-auto680):01321 * The next 4 words call system dependant I/O routines
+ (fig-forth-auto680):01322 * which are listed after word "-->" ( lable: "arrow" )
+ (fig-forth-auto680):01323 * in the dictionary.
+ (fig-forth-auto680):01324 *
+ (fig-forth-auto680):01325 * ======>> 13 <<
+ (fig-forth-auto680):01326 * ( c --- )
+ (fig-forth-auto680):01327 * Write c to the output device (screen or printer).
+ (fig-forth-auto680):01328 * ROM Uses the ECB device number at address $6F,
+ (fig-forth-auto680):01329 * -2 is printer, 0 is screen.
+153A 84 (fig-forth-auto680):01330 FCB $84
+153B 454D49 (fig-forth-auto680):01331 FCC 'EMI' ; 'EMIT'
+153E D4 (fig-forth-auto680):01332 FCB $D4
+153F 14F3 (fig-forth-auto680):01333 FDB ENCLOS-10
+1541 1543 (fig-forth-auto680):01334 EMIT FDB *+NATWID
+1543 3706 (fig-forth-auto680):01335 PULU D
+1545 171067 (fig-forth-auto680):01336 LBSR PEMIT ; PEMIT expects the character in D.
+1548 0C33 (fig-forth-auto680):01337 INC <XOUT+1
+154A 2602 (fig-forth-auto680):01338 BNE EMITDN
+154C 0C32 (fig-forth-auto680):01339 INC <XOUT
+154E 39 (fig-forth-auto680):01340 EMITDN RTS
+ (fig-forth-auto680):01341 * PULS A ;
+ (fig-forth-auto680):01342 * PULS A ;
+ (fig-forth-auto680):01343 * JSR PEMIT
+ (fig-forth-auto680):01344 * LDX UP
+ (fig-forth-auto680):01345 * INC XOUT+1-UORIG,X
+ (fig-forth-auto680):01346 * BNE *+4 ;
+ (fig-forth-auto680):01347 * ****WARNING**** HARD OFFSET: *+4 ****
+ (fig-forth-auto680):01348 * INC XOUT-UORIG,X
+ (fig-forth-auto680):01349 * JMP NEXT
+ (fig-forth-auto680):01350 *
+ (fig-forth-auto680):01351 * ======>> 14 <<
+ (fig-forth-auto680):01352 * ( --- c )
+ (fig-forth-auto680):01353 * ( --- BREAK )
+ (fig-forth-auto680):01354 * Wait for a key from the keyboard.
+ (fig-forth-auto680):01355 * If the key is BREAK, set the high byte (result $FF03).
+154F 83 (fig-forth-auto680):01356 FCB $83
+1550 4B45 (fig-forth-auto680):01357 FCC 'KE' ; 'KEY'
+1552 D9 (fig-forth-auto680):01358 FCB $D9
+1553 153A (fig-forth-auto680):01359 FDB EMIT-7
+1555 1557 (fig-forth-auto680):01360 KEY FDB *+NATWID
+1557 171062 (fig-forth-auto680):01361 LBSR PKEY ; PKEY leaves the key/break code in D.
+155A 3606 (fig-forth-auto680):01362 PSHU D
+155C 39 (fig-forth-auto680):01363 RTS
+ (fig-forth-auto680):01364 * JSR PKEY
+ (fig-forth-auto680):01365 * PSHS A ;
+ (fig-forth-auto680):01366 * CLRA ;
+ (fig-forth-auto680):01367 * PSHS A ;
+ (fig-forth-auto680):01368 * JMP NEXT
+ (fig-forth-auto680):01369 *
+ (fig-forth-auto680):01370 * ======>> 15 <<
+ (fig-forth-auto680):01371 * ( --- f )
+ (fig-forth-auto680):01372 * Scan keyboard, but do not wait.
+ (fig-forth-auto680):01373 * Return 0 if no key,
+ (fig-forth-auto680):01374 * BREAK ($ff03) if BREAK is pressed,
+ (fig-forth-auto680):01375 * or key currently pressed.
+155D 89 (fig-forth-auto680):01376 FCB $89
+155E 3F5445524D494E41 (fig-forth-auto680):01377 FCC '?TERMINA' ; '?TERMINAL'
+1566 CC (fig-forth-auto680):01378 FCB $CC
+1567 154F (fig-forth-auto680):01379 FDB KEY-6
+1569 156B (fig-forth-auto680):01380 QTERM FDB *+NATWID
+156B 171073 (fig-forth-auto680):01381 LBSR PQTER ; PQTER leaves the flag/key in D.
+156E 3606 (fig-forth-auto680):01382 PSHU D
+1570 39 (fig-forth-auto680):01383 RTS
+ (fig-forth-auto680):01384 * JSR PQTER
+ (fig-forth-auto680):01385 * CLRB ;
+ (fig-forth-auto680):01386 * JMP PUSHBA stack the flag
+ (fig-forth-auto680):01387 *
+ (fig-forth-auto680):01388 * ======>> 16 <<
+ (fig-forth-auto680):01389 * ( --- )
+ (fig-forth-auto680):01390 * EMIT a Carriage Return (ASCII CR).
+1571 82 (fig-forth-auto680):01391 FCB $82
+1572 43 (fig-forth-auto680):01392 FCC 'C' ; 'CR'
+1573 D2 (fig-forth-auto680):01393 FCB $D2
+1574 155D (fig-forth-auto680):01394 FDB QTERM-12
+1576 1578 (fig-forth-auto680):01395 CR FDB *+NATWID
+1578 161071 (fig-forth-auto680):01396 LBRA PCR ; Nothing really to do here.
+ (fig-forth-auto680):01397 * JSR PCR
+ (fig-forth-auto680):01398 * JMP NEXT
+ (fig-forth-auto680):01399 *
+ (fig-forth-auto680):01400 * ######>> screen 22 <<
+ (fig-forth-auto680):01401 * ======>> 17 <<
+ (fig-forth-auto680):01402 * ( source target count --- )
+ (fig-forth-auto680):01403 * Copy/move count bytes from source to target.
+ (fig-forth-auto680):01404 * Moves ascending addresses,
+ (fig-forth-auto680):01405 * so that overlapping only works if the source is above the destination.
+157B 85 (fig-forth-auto680):01406 FCB $85
+157C 434D4F56 (fig-forth-auto680):01407 FCC 'CMOV' ; 'CMOVE' : source, destination, count
+1580 C5 (fig-forth-auto680):01408 FCB $C5
+1581 1571 (fig-forth-auto680):01409 FDB CR-5
+1583 1585 (fig-forth-auto680):01410 CMOVE FDB *+NATWID
+ (fig-forth-auto680):01411 * One way: ; takes ( 37+17*count+9*(count/256) cycles )
+1585 3420 (fig-forth-auto680):01412 PSHS Y ; #2~7 ; Gotta have our pointers.
+1587 3736 (fig-forth-auto680):01413 PULU D,X,Y ; #2~11
+1589 3402 (fig-forth-auto680):01414 PSHS A ; #2~6 ; Gotta have our pointers.
+158B 2004 (fig-forth-auto680):01415 BRA CMOVLE ; #2~3
+158D (fig-forth-auto680):01416 CMOVLP
+158D A6A0 (fig-forth-auto680):01417 LDA ,Y+ ; #2~6
+158F A780 (fig-forth-auto680):01418 STA ,X+ ; #2~6
+1591 (fig-forth-auto680):01419 CMOVLE
+1591 C001 (fig-forth-auto680):01420 SUBB #1 ; #2~2
+1593 24F8 (fig-forth-auto680):01421 BCC CMOVLP ; #2~3
+1595 6AE4 (fig-forth-auto680):01422 DEC ,S ; #2=6
+1597 2AF4 (fig-forth-auto680):01423 BPL CMOVLP ; #2~3
+1599 35A2 (fig-forth-auto680):01424 PULS A,Y,PC ; #2~10
+ (fig-forth-auto680):01425 * Another way ; takes ( 42+17*count+9*(count/256) cycles )
+ (fig-forth-auto680):01426 * LDD #0 ; #3~3
+ (fig-forth-auto680):01427 * SUBD ,U++ ; #2~9 ; invert the count
+ (fig-forth-auto680):01428 * PSHS A,Y ; #2~8
+ (fig-forth-auto680):01429 * PULU X,Y ; #2~9
+ (fig-forth-auto680):01430 * BEQ CMOVEX ; #2~3
+ (fig-forth-auto680):01431 * CMOVEL
+ (fig-forth-auto680):01432 * LDA ,Y+ ; #2~6
+ (fig-forth-auto680):01433 * STA ,X+ ; #2~6
+ (fig-forth-auto680):01434 * INCB ; #1~2
+ (fig-forth-auto680):01435 * BNE CMOVEL ; #2~3
+ (fig-forth-auto680):01436 * INC ,S ; #2~6
+ (fig-forth-auto680):01437 * BNE CMOVEL ; #2~3
+ (fig-forth-auto680):01438 * CMOVEX
+ (fig-forth-auto680):01439 * PULS A,Y,PC ; #2~10
+ (fig-forth-auto680):01440 * Yet another way ; takes ( 37+29*count cycles )
+ (fig-forth-auto680):01441 * PSHS Y ; #2~7
+ (fig-forth-auto680):01442 * LDX NATWID,U ; #2~6
+ (fig-forth-auto680):01443 * LDY NATWID,U ; #3~7
+ (fig-forth-auto680):01444 * BRA CMOVLE ; #2~3
+ (fig-forth-auto680):01445 * CMOVLP
+ (fig-forth-auto680):01446 * LDA ,Y+ ; #2~6
+ (fig-forth-auto680):01447 * STA ,X+ ; #2~6
+ (fig-forth-auto680):01448 * CMOVLE
+ (fig-forth-auto680):01449 * LDD ,U ; #2~5
+ (fig-forth-auto680):01450 * SUBD #1 ; #3~4
+ (fig-forth-auto680):01451 * STD ,U ; #2~5
+ (fig-forth-auto680):01452 * BPL CMOVLP ; #2~3
+ (fig-forth-auto680):01453 * LEAU 3*NATWID,U ; #2~5
+ (fig-forth-auto680):01454 * PULS Y,PC ; #2~9
+ (fig-forth-auto680):01455 * Yet another way ; takes ( 44+24*odd+33*count/2 cycles )
+ (fig-forth-auto680):01456 * PSHS Y ; #2~7
+ (fig-forth-auto680):01457 * LDX NATWID,U ; #2~6
+ (fig-forth-auto680):01458 * LDY 2*NATWID,U ; #3~7
+ (fig-forth-auto680):01459 * LDD ,U ; #2~5
+ (fig-forth-auto680):01460 * BITB #1 ; #2~2
+ (fig-forth-auto680):01461 * BEQ CMOVLE ; #2~3
+ (fig-forth-auto680):01462 * SUBD #1 ; #3~4
+ (fig-forth-auto680):01463 * STD ,U ; #2~5
+ (fig-forth-auto680):01464 * LDA ,Y+ ; #2~6
+ (fig-forth-auto680):01465 * STA ,X+ ; #2~6
+ (fig-forth-auto680):01466 * BRA CMOVLE ; #2~3
+ (fig-forth-auto680):01467 * CMOVLP
+ (fig-forth-auto680):01468 * LDD ,Y++ ; #2~8
+ (fig-forth-auto680):01469 * STD ,X++ ; #2~8
+ (fig-forth-auto680):01470 * CMOVLI
+ (fig-forth-auto680):01471 * LDD ,U ; #2~5
+ (fig-forth-auto680):01472 * CMOVLE
+ (fig-forth-auto680):01473 * SUBD #2 ; #3~4
+ (fig-forth-auto680):01474 * STD ,U ; #2~5
+ (fig-forth-auto680):01475 * BPL CMOVLP ; #2~3
+ (fig-forth-auto680):01476 * LEAU 3*NATWID,U ; #2~5
+ (fig-forth-auto680):01477 * PULS Y,PC ; #2~9
+ (fig-forth-auto680):01478 * From the 6800 model:
+ (fig-forth-auto680):01479 * CMOVE FDB *+2 takes ( 43+47*count cycles ) on 6800
+ (fig-forth-auto680):01480 * LDX #N
+ (fig-forth-auto680):01481 * LDB #6
+ (fig-forth-auto680):01482 * CMOV1 PULS A ;
+ (fig-forth-auto680):01483 * STA 0,X move parameters to scratch area
+ (fig-forth-auto680):01484 * LEAX 1,X ;
+ (fig-forth-auto680):01485 * DECB ;
+ (fig-forth-auto680):01486 * BNE CMOV1
+ (fig-forth-auto680):01487 * CMOV2 LDA N
+ (fig-forth-auto680):01488 * LDB N+1
+ (fig-forth-auto680):01489 * SUBB #1
+ (fig-forth-auto680):01490 * SBCA #0
+ (fig-forth-auto680):01491 * STA N
+ (fig-forth-auto680):01492 * STB N+1
+ (fig-forth-auto680):01493 * BCS CMOV3
+ (fig-forth-auto680):01494 * LDX N+4
+ (fig-forth-auto680):01495 * LDA 0,X
+ (fig-forth-auto680):01496 * LEAX 1,X ;
+ (fig-forth-auto680):01497 * STX N+4
+ (fig-forth-auto680):01498 * LDX N+2
+ (fig-forth-auto680):01499 * STA 0,X
+ (fig-forth-auto680):01500 * LEAX 1,X ;
+ (fig-forth-auto680):01501 * STX N+2
+ (fig-forth-auto680):01502 * BRA CMOV2
+ (fig-forth-auto680):01503 * CMOV3 JMP NEXT
+ (fig-forth-auto680):01504 *
+ (fig-forth-auto680):01505 * ######>> screen 23 <<
+ (fig-forth-auto680):01506 * ======>> 18 <<
+ (fig-forth-auto680):01507 * ( u1 u2 --- ud )
+ (fig-forth-auto680):01508 * Multiplies the top two unsigned integers,
+ (fig-forth-auto680):01509 * yielding a double integer product.
+159B 82 (fig-forth-auto680):01510 FCB $82
+159C 55 (fig-forth-auto680):01511 FCC 'U' ; 'U*'
+159D AA (fig-forth-auto680):01512 FCB $AA
+159E 157B (fig-forth-auto680):01513 FDB CMOVE-8
+15A0 15A2 (fig-forth-auto680):01514 USTAR FDB *+NATWID
+15A2 335C (fig-forth-auto680):01515 LEAU -2*NATWID,U
+15A4 A645 (fig-forth-auto680):01516 LDA 2*NATWID+1,U ; least
+15A6 E647 (fig-forth-auto680):01517 LDB 3*NATWID+1,U
+15A8 3D (fig-forth-auto680):01518 MUL
+15A9 ED42 (fig-forth-auto680):01519 STD NATWID,U
+15AB A644 (fig-forth-auto680):01520 LDA 2*NATWID,U ; most
+15AD E646 (fig-forth-auto680):01521 LDB 3*NATWID,U
+15AF 3D (fig-forth-auto680):01522 MUL
+15B0 EDC4 (fig-forth-auto680):01523 STD ,U
+15B2 EC45 (fig-forth-auto680):01524 LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi)
+15B4 3D (fig-forth-auto680):01525 MUL
+15B5 E341 (fig-forth-auto680):01526 ADDD 1,U
+15B7 2402 (fig-forth-auto680):01527 BCC USTAR3
+15B9 6CC4 (fig-forth-auto680):01528 INC ,U
+15BB ED41 (fig-forth-auto680):01529 USTAR3 STD 1,U
+15BD A644 (fig-forth-auto680):01530 LDA 2*NATWID,U ; second inner (u2 hi)
+15BF E646 (fig-forth-auto680):01531 LDB 3*NATWID,U ; (u1 lo)
+15C1 3D (fig-forth-auto680):01532 MUL
+15C2 E341 (fig-forth-auto680):01533 ADDD 1,U
+15C4 2402 (fig-forth-auto680):01534 BCC USTAR4
+15C6 6CC4 (fig-forth-auto680):01535 INC ,U
+15C8 ED41 (fig-forth-auto680):01536 USTAR4 STD 1,U
+15CA 3716 (fig-forth-auto680):01537 PULU D,X
+15CC EDC4 (fig-forth-auto680):01538 STD ,U
+15CE AF42 (fig-forth-auto680):01539 STX NATWID,U
+15D0 39 (fig-forth-auto680):01540 RTS
+ (fig-forth-auto680):01541 *
+ (fig-forth-auto680):01542 * from 6800 model:
+ (fig-forth-auto680):01543 * BSR USTARS
+ (fig-forth-auto680):01544 * LEAS 1,S ;
+ (fig-forth-auto680):01545 * LEAS 1,S ;
+ (fig-forth-auto680):01546 * JMP PUSHBA
+ (fig-forth-auto680):01547 *
+ (fig-forth-auto680):01548 * The following is a subroutine which
+ (fig-forth-auto680):01549 * multiplies top 2 words on stack,
+ (fig-forth-auto680):01550 * leaving 32-bit result: high order word in A,B
+ (fig-forth-auto680):01551 * low order word in 2nd word of stack.
+ (fig-forth-auto680):01552 *
+ (fig-forth-auto680):01553 * USTARS LDA #16 bits/word counter
+ (fig-forth-auto680):01554 * PSHS A ;
+ (fig-forth-auto680):01555 * CLRA ;
+ (fig-forth-auto680):01556 * CLRB ;
+ (fig-forth-auto680):01557 * TFR S,X ; TSX :
+ (fig-forth-auto680):01558 * USTAR2 ROR 5,X shift multiplier
+ (fig-forth-auto680):01559 * ROR 6,X
+ (fig-forth-auto680):01560 * DEC 0,X done?
+ (fig-forth-auto680):01561 * BMI USTAR4
+ (fig-forth-auto680):01562 * BCC USTAR3
+ (fig-forth-auto680):01563 * ADDB 4,X
+ (fig-forth-auto680):01564 * ADCA 3,X
+ (fig-forth-auto680):01565 * USTAR3 RORA ;
+ (fig-forth-auto680):01566 * RORB ; shift result
+ (fig-forth-auto680):01567 * BRA USTAR2
+ (fig-forth-auto680):01568 * USTAR4 LEAS 1,S ; dump counter
+ (fig-forth-auto680):01569 * RTS
+ (fig-forth-auto680):01570 *
+ (fig-forth-auto680):01571 * ######>> screen 24 <<
+ (fig-forth-auto680):01572 * ======>> 19 <<
+ (fig-forth-auto680):01573 * ( ud u --- uremainder uquotient )
+ (fig-forth-auto680):01574 * Divides the top unsigned integer
+ (fig-forth-auto680):01575 * into the second and third words on the stack
+ (fig-forth-auto680):01576 * as a single unsigned double integer,
+ (fig-forth-auto680):01577 * leaving the remainder and quotient (quotient on top)
+ (fig-forth-auto680):01578 * as unsigned integers.
+ (fig-forth-auto680):01579 *
+ (fig-forth-auto680):01580 * The smaller the divisor, the more likely dropping the high word
+ (fig-forth-auto680):01581 * of the quotient loses significant bits. See M/MOD .
+ (fig-forth-auto680):01582 *
+15D1 82 (fig-forth-auto680):01583 FCB $82
+15D2 55 (fig-forth-auto680):01584 FCC 'U' ; 'U/'
+15D3 AF (fig-forth-auto680):01585 FCB $AF
+15D4 159B (fig-forth-auto680):01586 FDB USTAR-5
+15D6 15D8 (fig-forth-auto680):01587 USLASH FDB *+NATWID
+15D8 8611 (fig-forth-auto680):01588 LDA #17 ; bit ct
+15DA 3402 (fig-forth-auto680):01589 PSHS A
+15DC EC42 (fig-forth-auto680):01590 LDD NATWID,U ; dividend
+15DE 10A3C4 (fig-forth-auto680):01591 USLDIV CMPD ,U ; divisor
+15E1 2404 (fig-forth-auto680):01592 BHS USLSUB
+15E3 1CFE (fig-forth-auto680):01593 ANDCC #~1 ; carry clear
+15E5 2004 (fig-forth-auto680):01594 BRA USLBIT
+15E7 A3C4 (fig-forth-auto680):01595 USLSUB SUBD ,U
+15E9 1A01 (fig-forth-auto680):01596 ORCC #1 ; quotient, (carry set)
+15EB 6945 (fig-forth-auto680):01597 USLBIT ROL 2*NATWID+1,U ; save it
+15ED 6944 (fig-forth-auto680):01598 ROL 2*NATWID,U
+15EF 6AE4 (fig-forth-auto680):01599 DEC ,S ; more bits?
+15F1 2706 (fig-forth-auto680):01600 BEQ USLR
+15F3 59 (fig-forth-auto680):01601 ROLB ; remainder
+15F4 49 (fig-forth-auto680):01602 ROLA
+15F5 24E7 (fig-forth-auto680):01603 BCC USLDIV
+15F7 20EE (fig-forth-auto680):01604 BRA USLSUB
+15F9 3342 (fig-forth-auto680):01605 USLR LEAU NATWID,U
+15FB AE42 (fig-forth-auto680):01606 LDX NATWID,U
+15FD ED42 (fig-forth-auto680):01607 STD NATWID,U
+15FF AFC4 (fig-forth-auto680):01608 STX ,U
+1601 3582 (fig-forth-auto680):01609 PULS A,PC ; Avoiding a LEAS 1,S by discarding A.
+ (fig-forth-auto680):01610 *
+ (fig-forth-auto680):01611 * from 6800 model:
+ (fig-forth-auto680):01612 * LDA #17
+ (fig-forth-auto680):01613 * PSHS A ;
+ (fig-forth-auto680):01614 * TFR S,X ; TSX :
+ (fig-forth-auto680):01615 * LDA 3,X
+ (fig-forth-auto680):01616 * LDB 4,X
+ (fig-forth-auto680):01617 * USL1 CMPA 1,X
+ (fig-forth-auto680):01618 * BHI USL3
+ (fig-forth-auto680):01619 * BCS USL2
+ (fig-forth-auto680):01620 * CMPB 2,X
+ (fig-forth-auto680):01621 * BCC USL3
+ (fig-forth-auto680):01622 * USL2 ANDCC #~$01 ; CLC :
+ (fig-forth-auto680):01623 * BRA USL4
+ (fig-forth-auto680):01624 * USL3 SUBB 2,X
+ (fig-forth-auto680):01625 * SBCA 1,X
+ (fig-forth-auto680):01626 * ORCC #$01 ; SEC :
+ (fig-forth-auto680):01627 * USL4 ROL 6,X
+ (fig-forth-auto680):01628 * ROL 5,X
+ (fig-forth-auto680):01629 * DEC 0,X
+ (fig-forth-auto680):01630 * BEQ USL5
+ (fig-forth-auto680):01631 * ROLB ;
+ (fig-forth-auto680):01632 * ROLA ;
+ (fig-forth-auto680):01633 * BCC USL1
+ (fig-forth-auto680):01634 * BRA USL3
+ (fig-forth-auto680):01635 * USL5 LEAS 1,S ;
+ (fig-forth-auto680):01636 * LEAS 1,S ;
+ (fig-forth-auto680):01637 * LEAS 1,S ;
+ (fig-forth-auto680):01638 * LEAS 1,S ;
+ (fig-forth-auto680):01639 * LEAS 1,S ;
+ (fig-forth-auto680):01640 * JMP SWAP+4 reverse quotient & remainder
+ (fig-forth-auto680):01641 *
+ (fig-forth-auto680):01642 * ######>> screen 25 <<
+ (fig-forth-auto680):01643 * ======>> 20 <<
+ (fig-forth-auto680):01644 * ( n1 n2 --- n )
+ (fig-forth-auto680):01645 * Bitwise and the top two integers.
+1603 83 (fig-forth-auto680):01646 FCB $83
+1604 414E (fig-forth-auto680):01647 FCC 'AN' ; 'AND'
+1606 C4 (fig-forth-auto680):01648 FCB $C4
+1607 15D1 (fig-forth-auto680):01649 FDB USLASH-5
+1609 160B (fig-forth-auto680):01650 AND FDB *+NATWID
+160B 3706 (fig-forth-auto680):01651 PULU A,B
+160D E441 (fig-forth-auto680):01652 ANDB 1,U
+160F A4C4 (fig-forth-auto680):01653 ANDA ,U
+1611 EDC4 (fig-forth-auto680):01654 STD ,U
+1613 39 (fig-forth-auto680):01655 RTS
+ (fig-forth-auto680):01656 * PULS A ;
+ (fig-forth-auto680):01657 * PULS B ;
+ (fig-forth-auto680):01658 * TFR S,X ; TSX :
+ (fig-forth-auto680):01659 * ANDB 1,X
+ (fig-forth-auto680):01660 * ANDA 0,X
+ (fig-forth-auto680):01661 * JMP STABX
+ (fig-forth-auto680):01662 *
+ (fig-forth-auto680):01663 * ======>> 21 <<
+ (fig-forth-auto680):01664 * ( n1 n2 --- n )
+ (fig-forth-auto680):01665 * Bitwise or the top two integers.
+1614 82 (fig-forth-auto680):01666 FCB $82
+1615 4F (fig-forth-auto680):01667 FCC 'O' ; 'OR'
+1616 D2 (fig-forth-auto680):01668 FCB $D2
+1617 1603 (fig-forth-auto680):01669 FDB AND-6
+1619 161B (fig-forth-auto680):01670 OR FDB *+NATWID
+161B 3706 (fig-forth-auto680):01671 PULU A,B
+161D EA41 (fig-forth-auto680):01672 ORB 1,U
+161F AAC4 (fig-forth-auto680):01673 ORA ,U
+1621 EDC4 (fig-forth-auto680):01674 STD ,U
+1623 39 (fig-forth-auto680):01675 RTS
+ (fig-forth-auto680):01676 * PULS A ;
+ (fig-forth-auto680):01677 * PULS B ;
+ (fig-forth-auto680):01678 * TFR S,X ; TSX :
+ (fig-forth-auto680):01679 * ORB 1,X
+ (fig-forth-auto680):01680 * ORA 0,X
+ (fig-forth-auto680):01681 * JMP STABX
+ (fig-forth-auto680):01682 *
+ (fig-forth-auto680):01683 * ======>> 22 <<
+ (fig-forth-auto680):01684 * ( n1 n2 --- n )
+ (fig-forth-auto680):01685 * Bitwise exclusive or the top two integers.
+1624 83 (fig-forth-auto680):01686 FCB $83
+1625 584F (fig-forth-auto680):01687 FCC 'XO' ; 'XOR'
+1627 D2 (fig-forth-auto680):01688 FCB $D2
+1628 1614 (fig-forth-auto680):01689 FDB OR-5
+162A 162C (fig-forth-auto680):01690 XOR FDB *+NATWID
+162C 3706 (fig-forth-auto680):01691 PULU A,B
+162E E841 (fig-forth-auto680):01692 EORB 1,U
+1630 A8C4 (fig-forth-auto680):01693 EORA ,U
+1632 EDC4 (fig-forth-auto680):01694 STD ,U
+1634 39 (fig-forth-auto680):01695 RTS
+ (fig-forth-auto680):01696 * PULS A ;
+ (fig-forth-auto680):01697 * PULS B ;
+ (fig-forth-auto680):01698 * TFR S,X ; TSX :
+ (fig-forth-auto680):01699 * EORB 1,X
+ (fig-forth-auto680):01700 * EORA 0,X
+ (fig-forth-auto680):01701 * JMP STABX
+ (fig-forth-auto680):01702 *
+ (fig-forth-auto680):01703 * ######>> screen 26 <<
+ (fig-forth-auto680):01704 * ======>> 23 <<
+ (fig-forth-auto680):01705 * ( --- adr )
+ (fig-forth-auto680):01706 * Fetch the parameter stack pointer (before it is pushed).
+ (fig-forth-auto680):01707 * This points at whatever was on the top of stack before.
+1635 83 (fig-forth-auto680):01708 FCB $83
+1636 5350 (fig-forth-auto680):01709 FCC 'SP' ; 'SP@'
+1638 C0 (fig-forth-auto680):01710 FCB $C0
+1639 1624 (fig-forth-auto680):01711 FDB XOR-6
+163B 163D (fig-forth-auto680):01712 SPAT FDB *+NATWID
+163D 1F31 (fig-forth-auto680):01713 TFR U,X
+163F 3610 (fig-forth-auto680):01714 PSHU X
+1641 39 (fig-forth-auto680):01715 RTS
+ (fig-forth-auto680):01716 * TFR S,X ; TSX :
+ (fig-forth-auto680):01717 * STX N scratch area
+ (fig-forth-auto680):01718 * LDX #N
+ (fig-forth-auto680):01719 * JMP GETX
+ (fig-forth-auto680):01720 *
+ (fig-forth-auto680):01721 * ======>> 24 <<
+ (fig-forth-auto680):01722 * ( whatever --- nothing )
+ (fig-forth-auto680):01723 * Initialize the parameter stack pointer from the USER variable S0.
+ (fig-forth-auto680):01724 * Effectively clears the stack.
+1642 83 (fig-forth-auto680):01725 FCB $83
+1643 5350 (fig-forth-auto680):01726 FCC 'SP' ; 'SP!'
+1645 A1 (fig-forth-auto680):01727 FCB $A1
+1646 1635 (fig-forth-auto680):01728 FDB SPAT-6
+1648 164A (fig-forth-auto680):01729 SPSTOR FDB *+NATWID
+164A DE1E (fig-forth-auto680):01730 LDU <XSPZER
+164C 39 (fig-forth-auto680):01731 RTS
+ (fig-forth-auto680):01732 * LDX UP
+ (fig-forth-auto680):01733 * LDX XSPZER-UORIG,X
+ (fig-forth-auto680):01734 * TFR X,S ; TXS : watch it ! X and S are not equal on 6800.
+ (fig-forth-auto680):01735 * JMP NEXT
+ (fig-forth-auto680):01736 * ======>> 25 <<
+ (fig-forth-auto680):01737 * ( whatever *** nothing )
+ (fig-forth-auto680):01738 * Initialize the return stack pointer from the initialization table
+ (fig-forth-auto680):01739 * instead of the user variable R0, for some reason.
+ (fig-forth-auto680):01740 * Quite possibly, this should be from R0.
+ (fig-forth-auto680):01741 * Effectively aborts all in process definitions, except the active one.
+ (fig-forth-auto680):01742 * An emergency measure, to be sure.
+ (fig-forth-auto680):01743 * The routine that calls this must never execute a return.
+ (fig-forth-auto680):01744 * So this should never be executed from the terminal, I guess.
+ (fig-forth-auto680):01745 * This is another that should be compile-time only, and in a separate vocabulary.
+164D 83 (fig-forth-auto680):01746 FCB $83
+164E 5250 (fig-forth-auto680):01747 FCC 'RP' ; 'RP!'
+1650 A1 (fig-forth-auto680):01748 FCB $A1
+1651 1642 (fig-forth-auto680):01749 FDB SPSTOR-6
+1653 1655 (fig-forth-auto680):01750 RPSTOR FDB *+NATWID
+1655 3510 (fig-forth-auto680):01751 PULS X ; But this guy has to return to his caller.
+1657 10FE1214 (fig-forth-auto680):01752 LDS RINIT
+165B 6E84 (fig-forth-auto680):01753 JMP ,X
+ (fig-forth-auto680):01754 * LDX RINIT initialize from rom constant
+ (fig-forth-auto680):01755 * STX RP
+ (fig-forth-auto680):01756 * JMP NEXT
+ (fig-forth-auto680):01757 *
+ (fig-forth-auto680):01758 * ======>> 26 <<
+ (fig-forth-auto680):01759 * ( ip *** )
+ (fig-forth-auto680):01760 * Pop IP from return stack (return from high-level definition).
+ (fig-forth-auto680):01761 * Can be used in a screen to force interpretion to terminate.
+ (fig-forth-auto680):01762 * Must not be executed when temporaries are saved on top of the return stack.
+165D 82 (fig-forth-auto680):01763 FCB $82
+165E 3B (fig-forth-auto680):01764 FCC ';' ; ';S'
+165F D3 (fig-forth-auto680):01765 FCB $D3
+1660 164D (fig-forth-auto680):01766 FDB RPSTOR-6
+1662 1664 (fig-forth-auto680):01767 SEMIS FDB *+NATWID
+1664 3526 (fig-forth-auto680):01768 PULS D,Y ; return address in D, and saved IP in Y.
+1666 1F05 (fig-forth-auto680):01769 TFR D,PC ; Synthetic return.
+ (fig-forth-auto680):01770 *
+ (fig-forth-auto680):01771 * Form 6800 model:
+ (fig-forth-auto680):01772 * LDX RP
+ (fig-forth-auto680):01773 * LEAX 1,X ;
+ (fig-forth-auto680):01774 * LEAX 1,X ;
+ (fig-forth-auto680):01775 * STX RP
+ (fig-forth-auto680):01776 * LDX 0,X get address we have just finished.
+ (fig-forth-auto680):01777 * JMP NEXT+2 increment the return address & do next word
+ (fig-forth-auto680):01778 *
+ (fig-forth-auto680):01779 * ######>> screen 27 <<
+ (fig-forth-auto680):01780 * ======>> 27 <<
+ (fig-forth-auto680):01781 * ( limit index *** index index )
+ (fig-forth-auto680):01782 * Force the terminating condition for the innermost loop by
+ (fig-forth-auto680):01783 * copying its index to its limit.
+ (fig-forth-auto680):01784 * Termination is postponed until the next
+ (fig-forth-auto680):01785 * LOOP or +LOOP instruction is executed.
+ (fig-forth-auto680):01786 * The index remains available for use until
+ (fig-forth-auto680):01787 * the LOOP or +LOOP instruction is encountered.
+ (fig-forth-auto680):01788 * Note that the assumption is that the current count is the correct count
+ (fig-forth-auto680):01789 * to end at, rather than pushing the count to the final count.
+1668 85 (fig-forth-auto680):01790 FCB $85
+1669 4C454156 (fig-forth-auto680):01791 FCC 'LEAV' ; 'LEAVE'
+166D C5 (fig-forth-auto680):01792 FCB $C5
+166E 165D (fig-forth-auto680):01793 FDB SEMIS-5
+1670 1672 (fig-forth-auto680):01794 LEAVE FDB *+NATWID
+1672 EC62 (fig-forth-auto680):01795 LDD NATWID,S ; Dodge the return address.
+1674 ED64 (fig-forth-auto680):01796 STD 2*NATWID,S
+1676 39 (fig-forth-auto680):01797 RTS
+ (fig-forth-auto680):01798 * LDX RP
+ (fig-forth-auto680):01799 * LDA 2,X
+ (fig-forth-auto680):01800 * LDB 3,X
+ (fig-forth-auto680):01801 * STA 4,X
+ (fig-forth-auto680):01802 * STB 5,X
+ (fig-forth-auto680):01803 * JMP NEXT
+ (fig-forth-auto680):01804 *
+ (fig-forth-auto680):01805 * ======>> 28 <<
+ (fig-forth-auto680):01806 * ( n --- )
+ (fig-forth-auto680):01807 * ( *** n )
+ (fig-forth-auto680):01808 * Move top of parameter stack to top of return stack.
+1677 82 (fig-forth-auto680):01809 FCB $82
+1678 3E (fig-forth-auto680):01810 FCC '>' ; '>R'
+1679 D2 (fig-forth-auto680):01811 FCB $D2
+167A 1668 (fig-forth-auto680):01812 FDB LEAVE-8
+167C 167E (fig-forth-auto680):01813 TOR FDB *+NATWID
+167E 3706 (fig-forth-auto680):01814 PULU A,B
+1680 AEE4 (fig-forth-auto680):01815 LDX ,S
+1682 EDE4 (fig-forth-auto680):01816 STD ,S ; Put it where the return address was.
+1684 6E84 (fig-forth-auto680):01817 JMP ,X
+ (fig-forth-auto680):01818 * LDX RP
+ (fig-forth-auto680):01819 * LEAX -1,X ;
+ (fig-forth-auto680):01820 * LEAX -1,X ;
+ (fig-forth-auto680):01821 * STX RP
+ (fig-forth-auto680):01822 * PULS A ;
+ (fig-forth-auto680):01823 * PULS B ;
+ (fig-forth-auto680):01824 * STA 2,X
+ (fig-forth-auto680):01825 * STB 3,X
+ (fig-forth-auto680):01826 * JMP NEXT
+ (fig-forth-auto680):01827 *
+ (fig-forth-auto680):01828 * ======>> 29 <<
+ (fig-forth-auto680):01829 * ( --- n )
+ (fig-forth-auto680):01830 * ( n *** )
+ (fig-forth-auto680):01831 * Move top of return stack to top of parameter stack.
+1686 82 (fig-forth-auto680):01832 FCB $82
+1687 52 (fig-forth-auto680):01833 FCC 'R' ; 'R>'
+1688 BE (fig-forth-auto680):01834 FCB $BE
+1689 1677 (fig-forth-auto680):01835 FDB TOR-5
+168B 168D (fig-forth-auto680):01836 FROMR FDB *+NATWID
+168D 3516 (fig-forth-auto680):01837 PULS D,X
+168F 3610 (fig-forth-auto680):01838 PSHU X
+1691 1F05 (fig-forth-auto680):01839 TFR D,PC
+ (fig-forth-auto680):01840 * LDX RP
+ (fig-forth-auto680):01841 * LDA 2,X
+ (fig-forth-auto680):01842 * LDB 3,X
+ (fig-forth-auto680):01843 * LEAX 1,X ;
+ (fig-forth-auto680):01844 * LEAX 1,X ;
+ (fig-forth-auto680):01845 * STX RP
+ (fig-forth-auto680):01846 * JMP PUSHBA
+ (fig-forth-auto680):01847 *
+ (fig-forth-auto680):01848 * ======>> 30 <<
+ (fig-forth-auto680):01849 * ( --- n )
+ (fig-forth-auto680):01850 * ( n *** n )
+ (fig-forth-auto680):01851 * Copy the top of return stack to top of parameter stack.
+ (fig-forth-auto680):01852 * A synonym for I.
+1693 81 (fig-forth-auto680):01853 FCB $81 R
+1694 D2 (fig-forth-auto680):01854 FCB $D2
+1695 1686 (fig-forth-auto680):01855 FDB FROMR-5
+1697 1467 (fig-forth-auto680):01856 R FDB I+NATWID
+ (fig-forth-auto680):01857
+ (fig-forth-auto680):01858 * LDX RP
+ (fig-forth-auto680):01859 * LEAX 1,X ;
+ (fig-forth-auto680):01860 * LEAX 1,X ;
+ (fig-forth-auto680):01861 * JMP GETX
+ (fig-forth-auto680):01862 *
+ (fig-forth-auto680):01863 * ######>> screen 28 <<
+ (fig-forth-auto680):01864 * ======>> 31 <<
+ (fig-forth-auto680):01865 * ( n --- n=0 )
+ (fig-forth-auto680):01866 * Logically invert top of stack;
+ (fig-forth-auto680):01867 * or flag true if top is zero, otherwise false.
+1699 82 (fig-forth-auto680):01868 FCB $82
+169A 30 (fig-forth-auto680):01869 FCC '0' ; '0='
+169B BD (fig-forth-auto680):01870 FCB $BD
+169C 1693 (fig-forth-auto680):01871 FDB R-4
+169E 16A0 (fig-forth-auto680):01872 ZEQU FDB *+NATWID
+16A0 CC0000 (fig-forth-auto680):01873 LDD #0
+16A3 AEC4 (fig-forth-auto680):01874 LDX ,U
+16A5 2601 (fig-forth-auto680):01875 BNE ZEQUF
+16A7 5C (fig-forth-auto680):01876 INCB ; 1 is true
+16A8 EDC4 (fig-forth-auto680):01877 ZEQUF STD ,U
+16AA 39 (fig-forth-auto680):01878 RTS
+ (fig-forth-auto680):01879 * TFR S,X ; TSX :
+ (fig-forth-auto680):01880 * CLRA ;
+ (fig-forth-auto680):01881 * CLRB ;
+ (fig-forth-auto680):01882 * LDX 0,X
+ (fig-forth-auto680):01883 * BNE ZEQU2
+ (fig-forth-auto680):01884 * INCB ;
+ (fig-forth-auto680):01885 *ZEQU2 TFR S,X ; TSX :
+ (fig-forth-auto680):01886 * JMP STABX
+ (fig-forth-auto680):01887 *
+ (fig-forth-auto680):01888 * ======>> 32 <<
+ (fig-forth-auto680):01889 * ( n --- n<0 )
+ (fig-forth-auto680):01890 * Flag true if top is negative (MSbit set), otherwise false.
+16AB 82 (fig-forth-auto680):01891 FCB $82
+16AC 30 (fig-forth-auto680):01892 FCC '0' ; '0<'
+16AD BC (fig-forth-auto680):01893 FCB $BC
+16AE 1699 (fig-forth-auto680):01894 FDB ZEQU-5
+16B0 16B2 (fig-forth-auto680):01895 ZLESS FDB *+NATWID
+16B2 CC0000 (fig-forth-auto680):01896 LDD #0
+16B5 6DC4 (fig-forth-auto680):01897 TST ,U
+16B7 2A01 (fig-forth-auto680):01898 BPL ZLESSF
+16B9 5C (fig-forth-auto680):01899 INCB
+16BA EDC4 (fig-forth-auto680):01900 ZLESSF STD ,U
+16BC 39 (fig-forth-auto680):01901 RTS
+ (fig-forth-auto680):01902 * TFR S,X ; TSX :
+ (fig-forth-auto680):01903 * LDA #$80 check the sign bit
+ (fig-forth-auto680):01904 * ANDA 0,X
+ (fig-forth-auto680):01905 * BEQ ZLESS2
+ (fig-forth-auto680):01906 * CLRA ; if neg.
+ (fig-forth-auto680):01907 * LDB #1
+ (fig-forth-auto680):01908 * JMP STABX
+ (fig-forth-auto680):01909 * ZLESS2 CLRB ;
+ (fig-forth-auto680):01910 * JMP STABX
+ (fig-forth-auto680):01911 *
+ (fig-forth-auto680):01912 * ######>> screen 29 <<
+ (fig-forth-auto680):01913 * ======>> 33 <<
+ (fig-forth-auto680):01914 * ( n1 n2 --- n1+n2 )
+ (fig-forth-auto680):01915 * Add top two words.
+16BD 81 (fig-forth-auto680):01916 FCB $81 '+'
+16BE AB (fig-forth-auto680):01917 FCB $AB
+16BF 16AB (fig-forth-auto680):01918 FDB ZLESS-5
+16C1 16C3 (fig-forth-auto680):01919 PLUS FDB *+NATWID
+16C3 3706 (fig-forth-auto680):01920 PULU A,B ; #2~7
+16C5 E3C4 (fig-forth-auto680):01921 ADDD ,U ; #2~6
+16C7 EDC4 (fig-forth-auto680):01922 STD ,U ; #2~5
+16C9 39 (fig-forth-auto680):01923 RTS ; #1~5 =#7~23
+ (fig-forth-auto680):01924 * PULS A ;
+ (fig-forth-auto680):01925 * PULS B ;
+ (fig-forth-auto680):01926 * TFR S,X ; TSX :
+ (fig-forth-auto680):01927 * ADDB 1,X
+ (fig-forth-auto680):01928 * ADCA 0,X
+ (fig-forth-auto680):01929 * JMP STABX
+ (fig-forth-auto680):01930 *
+ (fig-forth-auto680):01931 * ======>> 34 <<
+ (fig-forth-auto680):01932 * ( d1 d2 --- d1+d2 )
+ (fig-forth-auto680):01933 * Add top two double integers.
+16CA 82 (fig-forth-auto680):01934 FCB $82
+16CB 44 (fig-forth-auto680):01935 FCC 'D' ; 'D+'
+16CC AB (fig-forth-auto680):01936 FCB $AB
+16CD 16BD (fig-forth-auto680):01937 FDB PLUS-4
+16CF 16D1 (fig-forth-auto680):01938 DPLUS FDB *+NATWID
+16D1 EC46 (fig-forth-auto680):01939 LDD 3*NATWID,U
+16D3 E342 (fig-forth-auto680):01940 ADDD NATWID,U
+16D5 ED46 (fig-forth-auto680):01941 STD 3*NATWID,U
+16D7 EC44 (fig-forth-auto680):01942 LDD 2*NATWID,U
+16D9 E941 (fig-forth-auto680):01943 ADCB 1,U
+16DB A9C4 (fig-forth-auto680):01944 ADCA ,U
+16DD 3344 (fig-forth-auto680):01945 LEAU 2*NATWID,U
+16DF EDC4 (fig-forth-auto680):01946 STD ,U
+16E1 39 (fig-forth-auto680):01947 RTS
+ (fig-forth-auto680):01948 * TFR S,X ; TSX :
+ (fig-forth-auto680):01949 * ANDCC #~$01 ; CLC :
+ (fig-forth-auto680):01950 * LDB #4
+ (fig-forth-auto680):01951 * DPLUS2 LDA 3,X
+ (fig-forth-auto680):01952 * ADCA 7,X
+ (fig-forth-auto680):01953 * STA 7,X
+ (fig-forth-auto680):01954 * LEAX -1,X ;
+ (fig-forth-auto680):01955 * DECB ;
+ (fig-forth-auto680):01956 * BNE DPLUS2
+ (fig-forth-auto680):01957 * LEAS 1,S ;
+ (fig-forth-auto680):01958 * LEAS 1,S ;
+ (fig-forth-auto680):01959 * LEAS 1,S ;
+ (fig-forth-auto680):01960 * LEAS 1,S ;
+ (fig-forth-auto680):01961 * JMP NEXT
+ (fig-forth-auto680):01962 *
+ (fig-forth-auto680):01963 * ======>> 35 <<
+ (fig-forth-auto680):01964 * ( n --- -n )
+ (fig-forth-auto680):01965 * Negate (two's complement) top of stack.
+16E2 85 (fig-forth-auto680):01966 FCB $85
+16E3 4D494E55 (fig-forth-auto680):01967 FCC 'MINU' ; 'MINUS'
+16E7 D3 (fig-forth-auto680):01968 FCB $D3
+16E8 16CA (fig-forth-auto680):01969 FDB DPLUS-5
+16EA 16EC (fig-forth-auto680):01970 MINUS FDB *+NATWID
+16EC CC0000 (fig-forth-auto680):01971 LDD #0 ; #3~3
+16EF A3C4 (fig-forth-auto680):01972 SUBD ,U ; #2~5
+16F1 EDC4 (fig-forth-auto680):01973 STD ,U ; #2~5
+16F3 39 (fig-forth-auto680):01974 RTS ; #1~5 = #8~18
+ (fig-forth-auto680):01975 *
+ (fig-forth-auto680):01976 * from 6800 model code:
+ (fig-forth-auto680):01977 * TFR S,X ; TSX :
+ (fig-forth-auto680):01978 * NEG 1,X
+ (fig-forth-auto680):01979 * BCC MINUS2
+ (fig-forth-auto680):01980 * NEG 0,X
+ (fig-forth-auto680):01981 * BRA MINUS3
+ (fig-forth-auto680):01982 * MINUS2 COM 0,X
+ (fig-forth-auto680):01983 * MINUS3 JMP NEXT
+ (fig-forth-auto680):01984 *
+ (fig-forth-auto680):01985 * ======>> 36 <<
+ (fig-forth-auto680):01986 * ( d --- -d )
+ (fig-forth-auto680):01987 * Negate (two's complement) top two words on stack as a double integer.
+16F4 86 (fig-forth-auto680):01988 FCB $86
+16F5 444D494E55 (fig-forth-auto680):01989 FCC 'DMINU' ; 'DMINUS'
+16FA D3 (fig-forth-auto680):01990 FCB $D3
+16FB 16E2 (fig-forth-auto680):01991 FDB MINUS-8
+16FD 16FF (fig-forth-auto680):01992 DMINUS FDB *+NATWID
+16FF CC0000 (fig-forth-auto680):01993 LDD #0 ; #3~3
+1702 A342 (fig-forth-auto680):01994 SUBD NATWID,U ; #2~7
+1704 ED42 (fig-forth-auto680):01995 STD NATWID,U ; #2~7
+1706 CC0000 (fig-forth-auto680):01996 LDD #0 ; #3~3
+1709 E241 (fig-forth-auto680):01997 SBCB 1,U ; #2~5
+170B A2C4 (fig-forth-auto680):01998 SBCA ,U ; #2~4
+170D EDC4 (fig-forth-auto680):01999 STD ,U ; #2~5
+170F 39 (fig-forth-auto680):02000 RTS ; #1~5 = #17~39
+ (fig-forth-auto680):02001 * TFR S,X ; TSX :
+ (fig-forth-auto680):02002 * COM 0,X
+ (fig-forth-auto680):02003 * COM 1,X
+ (fig-forth-auto680):02004 * COM 2,X
+ (fig-forth-auto680):02005 * NEG 3,X
+ (fig-forth-auto680):02006 * BNE DMINX
+ (fig-forth-auto680):02007 * INC 2,X
+ (fig-forth-auto680):02008 * BNE DMINX
+ (fig-forth-auto680):02009 * INC 1,X
+ (fig-forth-auto680):02010 * BNE DMINX
+ (fig-forth-auto680):02011 * INC 0,X
+ (fig-forth-auto680):02012 * DMINX JMP NEXT
+ (fig-forth-auto680):02013 *
+ (fig-forth-auto680):02014 * ######>> screen 30 <<
+ (fig-forth-auto680):02015 * ======>> 37 <<
+ (fig-forth-auto680):02016 * ( n1 n2 --- n1 n2 n1 )
+ (fig-forth-auto680):02017 * Push a copy of the second word on stack.
+1710 84 (fig-forth-auto680):02018 FCB $84
+1711 4F5645 (fig-forth-auto680):02019 FCC 'OVE' ; 'OVER'
+1714 D2 (fig-forth-auto680):02020 FCB $D2
+1715 16F4 (fig-forth-auto680):02021 FDB DMINUS-9
+1717 1719 (fig-forth-auto680):02022 OVER FDB *+NATWID
+1719 EC42 (fig-forth-auto680):02023 LDD NATWID,U
+171B 3606 (fig-forth-auto680):02024 PSHU D
+171D 39 (fig-forth-auto680):02025 RTS
+ (fig-forth-auto680):02026 * TFR S,X ; TSX :
+ (fig-forth-auto680):02027 * LDA 2,X
+ (fig-forth-auto680):02028 * LDB 3,X
+ (fig-forth-auto680):02029 * JMP PUSHBA
+ (fig-forth-auto680):02030 *
+ (fig-forth-auto680):02031 * ======>> 38 <<
+ (fig-forth-auto680):02032 * ( n --- )
+ (fig-forth-auto680):02033 * Discard the top word on stack.
+171E 84 (fig-forth-auto680):02034 FCB $84
+171F 44524F (fig-forth-auto680):02035 FCC 'DRO' ; 'DROP'
+1722 D0 (fig-forth-auto680):02036 FCB $D0
+1723 1710 (fig-forth-auto680):02037 FDB OVER-7
+1725 1727 (fig-forth-auto680):02038 DROP FDB *+NATWID
+1727 3706 (fig-forth-auto680):02039 PULU D ; Dodge the return address here, too, for heaven's sake!
+1729 EDC4 (fig-forth-auto680):02040 STD ,U
+172B 39 (fig-forth-auto680):02041 RTS
+ (fig-forth-auto680):02042 * LEAS 1,S ;
+ (fig-forth-auto680):02043 * LEAS 1,S ;
+ (fig-forth-auto680):02044 * JMP NEXT
+ (fig-forth-auto680):02045 *
+ (fig-forth-auto680):02046 * ======>> 39 <<
+ (fig-forth-auto680):02047 * ( n1 n2 --- n2 n1 )
+ (fig-forth-auto680):02048 * Swap the top two words on stack.
+172C 84 (fig-forth-auto680):02049 FCB $84
+172D 535741 (fig-forth-auto680):02050 FCC 'SWA' ; 'SWAP'
+1730 D0 (fig-forth-auto680):02051 FCB $D0
+1731 171E (fig-forth-auto680):02052 FDB DROP-7
+1733 1735 (fig-forth-auto680):02053 SWAP FDB *+NATWID
+1735 3716 (fig-forth-auto680):02054 PULU D,X
+1737 3606 (fig-forth-auto680):02055 PSHU D
+1739 3610 (fig-forth-auto680):02056 PSHU X
+173B 39 (fig-forth-auto680):02057 RTS
+ (fig-forth-auto680):02058 * PULS A ;
+ (fig-forth-auto680):02059 * PULS B ;
+ (fig-forth-auto680):02060 * TFR S,X ; TSX :
+ (fig-forth-auto680):02061 * LDX 0,X
+ (fig-forth-auto680):02062 * LEAS 1,S ;
+ (fig-forth-auto680):02063 * LEAS 1,S ;
+ (fig-forth-auto680):02064 * PSHS B ;
+ (fig-forth-auto680):02065 * PSHS A ;
+ (fig-forth-auto680):02066 * STX N
+ (fig-forth-auto680):02067 * LDX #N
+ (fig-forth-auto680):02068 * JMP GETX
+ (fig-forth-auto680):02069 *
+ (fig-forth-auto680):02070 * ======>> 40 <<
+ (fig-forth-auto680):02071 * ( n1 --- n1 n1 )
+ (fig-forth-auto680):02072 * Push a copy of the top word on stack.
+173C 83 (fig-forth-auto680):02073 FCB $83
+173D 4455 (fig-forth-auto680):02074 FCC 'DU' ; 'DUP'
+173F D0 (fig-forth-auto680):02075 FCB $D0
+1740 172C (fig-forth-auto680):02076 FDB SWAP-7
+1742 1744 (fig-forth-auto680):02077 DUP FDB *+NATWID
+1744 ECC4 (fig-forth-auto680):02078 LDD ,U
+1746 3606 (fig-forth-auto680):02079 PSHU D
+1748 39 (fig-forth-auto680):02080 RTS
+ (fig-forth-auto680):02081 * PULS A ;
+ (fig-forth-auto680):02082 * PULS B ;
+ (fig-forth-auto680):02083 * PSHS B ;
+ (fig-forth-auto680):02084 * PSHS A ;
+ (fig-forth-auto680):02085 * JMP PUSHBA
+ (fig-forth-auto680):02086 *
+ (fig-forth-auto680):02087 * ######>> screen 31 <<
+ (fig-forth-auto680):02088 * ======>> 41 <<
+ (fig-forth-auto680):02089 * ( n adr --- )
+ (fig-forth-auto680):02090 * Add the second word on stack to the word at the adr on top of stack.
+1749 82 (fig-forth-auto680):02091 FCB $82
+174A 2B (fig-forth-auto680):02092 FCC '+' ; '+!'
+174B A1 (fig-forth-auto680):02093 FCB $A1
+174C 173C (fig-forth-auto680):02094 FDB DUP-6
+174E 1750 (fig-forth-auto680):02095 PSTORE FDB *+NATWID
+1750 3710 (fig-forth-auto680):02096 PULU X
+1752 EC84 (fig-forth-auto680):02097 LDD ,X
+1754 E3C1 (fig-forth-auto680):02098 ADDD ,U++
+1756 ED84 (fig-forth-auto680):02099 STD ,X
+1758 39 (fig-forth-auto680):02100 RTS
+ (fig-forth-auto680):02101 * TFR S,X ; TSX :
+ (fig-forth-auto680):02102 * LDX 0,X
+ (fig-forth-auto680):02103 * LEAS 1,S ;
+ (fig-forth-auto680):02104 * LEAS 1,S ;
+ (fig-forth-auto680):02105 * PULS A ; get stack data
+ (fig-forth-auto680):02106 * PULS B ;
+ (fig-forth-auto680):02107 * ADDB 1,X add & store low byte
+ (fig-forth-auto680):02108 * STB 1,X
+ (fig-forth-auto680):02109 * ADCA 0,X add & store hi byte
+ (fig-forth-auto680):02110 * STA 0,X
+ (fig-forth-auto680):02111 * JMP NEXT
+ (fig-forth-auto680):02112 *
+ (fig-forth-auto680):02113 * ======>> 42 <<
+ (fig-forth-auto680):02114 * ( adr b --- )
+ (fig-forth-auto680):02115 * Exclusive or byte at adr with low byte of top word.
+1759 86 (fig-forth-auto680):02116 FCB $86
+175A 544F47474C (fig-forth-auto680):02117 FCC 'TOGGL' ; 'TOGGLE'
+175F C5 (fig-forth-auto680):02118 FCB $C5
+1760 1749 (fig-forth-auto680):02119 FDB PSTORE-5
+1762 1764 (fig-forth-auto680):02120 TOGGLE FDB *+NATWID
+1764 3716 (fig-forth-auto680):02121 PULU D,X
+1766 E884 (fig-forth-auto680):02122 EORB ,X
+1768 E784 (fig-forth-auto680):02123 STB ,X
+176A 39 (fig-forth-auto680):02124 RTS
+ (fig-forth-auto680):02125 * Using the model code would be less likely to introduce bugs,
+ (fig-forth-auto680):02126 * but that would sort-of defeat my purposes here.
+ (fig-forth-auto680):02127 * Anyway, I can borrow from theoretically known good bif-6809 code
+ (fig-forth-auto680):02128 * and it's fewer bytes and much faster code this way.
+ (fig-forth-auto680):02129 * TOGGLE
+ (fig-forth-auto680):02130 * FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
+ (fig-forth-auto680):02131 * FDB SEMIS
+ (fig-forth-auto680):02132 *
+ (fig-forth-auto680):02133 * ######>> screen 32 <<
+ (fig-forth-auto680):02134 * ======>> 43 <<
+ (fig-forth-auto680):02135 * ( adr --- n )
+ (fig-forth-auto680):02136 * Replace address on stack with the word at the address.
+176B 81 (fig-forth-auto680):02137 FCB $81 @
+176C C0 (fig-forth-auto680):02138 FCB $C0
+176D 1759 (fig-forth-auto680):02139 FDB TOGGLE-9
+176F 1771 (fig-forth-auto680):02140 AT FDB *+NATWID
+1771 ECD4 (fig-forth-auto680):02141 LDD [,U]
+1773 EDC4 (fig-forth-auto680):02142 STD ,U
+1775 39 (fig-forth-auto680):02143 RTS
+ (fig-forth-auto680):02144 * TFR S,X ; TSX :
+ (fig-forth-auto680):02145 * LDX 0,X get address
+ (fig-forth-auto680):02146 * LEAS 1,S ;
+ (fig-forth-auto680):02147 * LEAS 1,S ;
+ (fig-forth-auto680):02148 * JMP GETX
+ (fig-forth-auto680):02149 *
+ (fig-forth-auto680):02150 * ======>> 44 <<
+ (fig-forth-auto680):02151 * ( adr --- b )
+ (fig-forth-auto680):02152 * Replace address on top of stack with the byte at the address.
+ (fig-forth-auto680):02153 * High byte of result is clear.
+1776 82 (fig-forth-auto680):02154 FCB $82
+1777 43 (fig-forth-auto680):02155 FCC 'C' ; 'C@'
+1778 C0 (fig-forth-auto680):02156 FCB $C0
+1779 176B (fig-forth-auto680):02157 FDB AT-4
+177B 177D (fig-forth-auto680):02158 CAT FDB *+NATWID
+177D E6D4 (fig-forth-auto680):02159 LDB [,U]
+177F 4F (fig-forth-auto680):02160 CLRA
+1780 EDC4 (fig-forth-auto680):02161 STD ,U
+1782 39 (fig-forth-auto680):02162 RTS
+ (fig-forth-auto680):02163
+ (fig-forth-auto680):02164
+ (fig-forth-auto680):02165 * TFR S,X ; TSX :
+ (fig-forth-auto680):02166 * LDX 0,X
+ (fig-forth-auto680):02167 * CLRA ;
+ (fig-forth-auto680):02168 * LDB 0,X
+ (fig-forth-auto680):02169 * LEAS 1,S ;
+ (fig-forth-auto680):02170 * LEAS 1,S ;
+ (fig-forth-auto680):02171 * JMP PUSHBA
+ (fig-forth-auto680):02172 *
+ (fig-forth-auto680):02173 * ======>> 45 <<
+ (fig-forth-auto680):02174 * ( n adr --- )
+ (fig-forth-auto680):02175 * Store second word on stack at address on top of stack.
+1783 81 (fig-forth-auto680):02176 FCB $81
+1784 A1 (fig-forth-auto680):02177 FCB $A1
+1785 1776 (fig-forth-auto680):02178 FDB CAT-5
+1787 1789 (fig-forth-auto680):02179 STORE FDB *+NATWID
+1789 EC42 (fig-forth-auto680):02180 LDD NATWID,U
+178B EDD4 (fig-forth-auto680):02181 STD [,U]
+178D 3344 (fig-forth-auto680):02182 LEAU 2*NATWID,U
+178F 39 (fig-forth-auto680):02183 RTS
+ (fig-forth-auto680):02184 * TFR S,X ; TSX :
+ (fig-forth-auto680):02185 * LDX 0,X get address
+ (fig-forth-auto680):02186 * LEAS 1,S ;
+ (fig-forth-auto680):02187 * LEAS 1,S ;
+ (fig-forth-auto680):02188 * JMP PULABX
+ (fig-forth-auto680):02189 *
+ (fig-forth-auto680):02190 * ======>> 46 <<
+ (fig-forth-auto680):02191 * ( b adr --- )
+ (fig-forth-auto680):02192 * Store low byte of second word on stack at address on top of stack.
+ (fig-forth-auto680):02193 * High byte is ignored.
+1790 82 (fig-forth-auto680):02194 FCB $82
+1791 43 (fig-forth-auto680):02195 FCC 'C' ; 'C!'
+1792 A1 (fig-forth-auto680):02196 FCB $A1
+1793 1783 (fig-forth-auto680):02197 FDB STORE-4
+1795 1797 (fig-forth-auto680):02198 CSTORE FDB *+NATWID
+1797 E643 (fig-forth-auto680):02199 LDB 3,U
+1799 E7D4 (fig-forth-auto680):02200 STB [,U]
+179B 3344 (fig-forth-auto680):02201 LEAU 2*NATWID,U
+179D 39 (fig-forth-auto680):02202 RTS
+ (fig-forth-auto680):02203 * TFR S,X ; TSX :
+ (fig-forth-auto680):02204 * LDX 0,X get address
+ (fig-forth-auto680):02205 * LEAS 1,S ;
+ (fig-forth-auto680):02206 * LEAS 1,S ;
+ (fig-forth-auto680):02207 * LEAS 1,S ;
+ (fig-forth-auto680):02208 * PULS B ;
+ (fig-forth-auto680):02209 * STB 0,X
+ (fig-forth-auto680):02210 * JMP NEXT
+ (fig-forth-auto680):02211 PAGE
+ (fig-forth-auto680):02212 *
+ (fig-forth-auto680):02213 * ######>> screen 33 <<
+ (fig-forth-auto680):02214 * ======>> 47 <<
+ (fig-forth-auto680):02215 * ( --- ) P
+ (fig-forth-auto680):02216 * { : name sundry-activities ; } typical input
+ (fig-forth-auto680):02217 * If executing (not compiling),
+ (fig-forth-auto680):02218 * record the data stack mark in CSP,
+ (fig-forth-auto680):02219 * Set the CONTEXT vocabulary to CURRENT,
+ (fig-forth-auto680):02220 * CREATE a header,
+ (fig-forth-auto680):02221 * set state to compile,
+ (fig-forth-auto680):02222 * and compile the call to the trailing native CPU machine code DOCOL.
+ (fig-forth-auto680):02223 *
+ (fig-forth-auto680):02224 * This would not be hard to flatten to native code.
+ (fig-forth-auto680):02225 * But that's not the purpose of a model.
+179E C1 (fig-forth-auto680):02226 FCB $C1 : immediate
+179F BA (fig-forth-auto680):02227 FCB $BA
+17A0 1790 (fig-forth-auto680):02228 FDB CSTORE-5
+17A2 17B61B671B231949 (fig-forth-auto680):02229 COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
+ 176F193B1787
+17B0 20651BE6 (fig-forth-auto680):02230 FDB CREATE,RBRAK
+17B4 1C35 (fig-forth-auto680):02231 FDB PSCODE
+ (fig-forth-auto680):02232
+ (fig-forth-auto680):02233 * Here is the IP pusher for allowing
+ (fig-forth-auto680):02234 * nested words in the virtual machine:
+ (fig-forth-auto680):02235 * ( ;S is the equivalent un-nester )
+ (fig-forth-auto680):02236
+ (fig-forth-auto680):02237 * ( *** oldIP )
+ (fig-forth-auto680):02238 * Characteristic of a colon (:) definition.
+ (fig-forth-auto680):02239 * Begins execution of a high-level definition,
+ (fig-forth-auto680):02240 * i. e., nests the definition and begins processing icodes.
+ (fig-forth-auto680):02241 * Mechanically, it pushes the IP (Y register)
+ (fig-forth-auto680):02242 * and loads the Parameter Field Address of the definition which
+ (fig-forth-auto680):02243 * called it into the IP.
+17B6 ECE4 (fig-forth-auto680):02244 DOCOL LDD ,S ; Save the return address.
+17B8 10AFE4 (fig-forth-auto680):02245 STY ,S ; Nest the old IP.
+17BB 3102 (fig-forth-auto680):02246 LEAY NATWID,X ; W still in X, bump to parameters, load as new IP.
+17BD 1F05 (fig-forth-auto680):02247 TFR D,PC ; synthetic return to interpret.
+ (fig-forth-auto680):02248
+ (fig-forth-auto680):02249 * DOCOL LDX RP make room in the stack
+ (fig-forth-auto680):02250 * LEAX -1,X ;
+ (fig-forth-auto680):02251 * LEAX -1,X ;
+ (fig-forth-auto680):02252 * STX RP
+ (fig-forth-auto680):02253 * LDA IP
+ (fig-forth-auto680):02254 * LDB IP+1
+ (fig-forth-auto680):02255 * STA 2,X Store address of the high level word
+ (fig-forth-auto680):02256 * STB 3,X that we are starting to execute
+ (fig-forth-auto680):02257 * LDX W Get first sub-word of that definition
+ (fig-forth-auto680):02258 * JMP NEXT+2 and execute it
+ (fig-forth-auto680):02259 *
+ (fig-forth-auto680):02260 * ======>> 48 <<
+ (fig-forth-auto680):02261 * ( --- ) P
+ (fig-forth-auto680):02262 * { : name sundry-activities ; } typical input
+ (fig-forth-auto680):02263 * ERROR check data stack against mark in CSP,
+ (fig-forth-auto680):02264 * compile ;S,
+ (fig-forth-auto680):02265 * unSMUDGE LATEST definition,
+ (fig-forth-auto680):02266 * and set state to interpretation.
+17BF C1 (fig-forth-auto680):02267 FCB $C1 ; imnediate code
+17C0 BB (fig-forth-auto680):02268 FCB $BB
+17C1 179E (fig-forth-auto680):02269 FDB COLON-4
+17C3 17B61B8F1BC41662 (fig-forth-auto680):02270 SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
+ 1BFA1BD8
+17CF 1662 (fig-forth-auto680):02271 FDB SEMIS
+ (fig-forth-auto680):02272 *
+ (fig-forth-auto680):02273 * ######>> screen 34 <<
+ (fig-forth-auto680):02274 * ======>> 49 <<
+ (fig-forth-auto680):02275 * ( n --- )
+ (fig-forth-auto680):02276 * { value CONSTANT name } typical input
+ (fig-forth-auto680):02277 * CREATE a header,
+ (fig-forth-auto680):02278 * unSMUDGE it,
+ (fig-forth-auto680):02279 * compile the constant value,
+ (fig-forth-auto680):02280 * and compile the call to the trailing native CPU machine code DOCON.
+17D1 88 (fig-forth-auto680):02281 FCB $88
+17D2 434F4E5354414E (fig-forth-auto680):02282 FCC 'CONSTAN' ; 'CONSTANT'
+17D9 D4 (fig-forth-auto680):02283 FCB $D4
+17DA 17BF (fig-forth-auto680):02284 FDB SEMI-4
+17DC 17B620651BFA19E0 (fig-forth-auto680):02285 CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
+ 1C35
+ (fig-forth-auto680):02286 * ( --- n )
+ (fig-forth-auto680):02287 * Characteristic of a CONSTANT.
+ (fig-forth-auto680):02288 * A CONSTANT simply loads its value from its parameter field
+ (fig-forth-auto680):02289 * and pushes it on the stack.
+17E6 EC02 (fig-forth-auto680):02290 DOCON LDD NATWID,X ; Get the first natural width word of the parameter field.
+17E8 3606 (fig-forth-auto680):02291 PSHU D
+17EA 39 (fig-forth-auto680):02292 RTS
+ (fig-forth-auto680):02293 * DOCON LDX W
+ (fig-forth-auto680):02294 * LDA 2,X
+ (fig-forth-auto680):02295 * LDB 3,X A & B now contain the constant
+ (fig-forth-auto680):02296 * JMP PUSHBA
+ (fig-forth-auto680):02297 *
+ (fig-forth-auto680):02298 * Not in model, needed for abstraction:
+ (fig-forth-auto680):02299 * ( --- NATWID )
+ (fig-forth-auto680):02300 * The byte width of objects on stack.
+17EB 86 (fig-forth-auto680):02301 FCB $86
+17EC 4E41545749 (fig-forth-auto680):02302 FCC 'NATWI' ; 'NATWID'
+17F1 C4 (fig-forth-auto680):02303 FCB $C4
+17F2 17D1 (fig-forth-auto680):02304 FDB CON-11
+17F4 17E6 (fig-forth-auto680):02305 NATWC FDB DOCON
+17F6 0002 (fig-forth-auto680):02306 NATWCV FDB NATWID
+ (fig-forth-auto680):02307 *
+ (fig-forth-auto680):02308 * Not in model, needed for abstraction:
+ (fig-forth-auto680):02309 * Note that this is not defined as an INCREMENTER!
+ (fig-forth-auto680):02310 * Coded to increment by the exact constant returned by NATWID
+ (fig-forth-auto680):02311 * ( n --- n+NATWID )
+17F8 84 (fig-forth-auto680):02312 FCB $84
+17F9 4E4154 (fig-forth-auto680):02313 FCC 'NAT' ; 'NAT+'
+17FC AB (fig-forth-auto680):02314 FCB $AB
+17FD 17EB (fig-forth-auto680):02315 FDB NATWC-9
+17FF 1801 (fig-forth-auto680):02316 NATP FDB *+NATWID
+1801 ECC4 (fig-forth-auto680):02317 LDD ,U
+1803 E38CF0 (fig-forth-auto680):02318 ADDD NATWCV,PCR ; Looking ahead, does not have to be PCRelative.
+1806 EDC4 (fig-forth-auto680):02319 STD ,U
+1808 39 (fig-forth-auto680):02320 RTS
+ (fig-forth-auto680):02321 * How this might have been done for 6800 model:
+ (fig-forth-auto680):02322 * CLRA ; We know the natural width is less than 255, LOL.
+ (fig-forth-auto680):02323 * LDAB NATWCV+1
+ (fig-forth-auto680):02324 * TSX
+ (fig-forth-auto680):02325 * ADDB 1,X
+ (fig-forth-auto680):02326 * ADCA ,X
+ (fig-forth-auto680):02327 * JMP STABX
+ (fig-forth-auto680):02328 *
+ (fig-forth-auto680):02329 * ======>> 50 <<
+ (fig-forth-auto680):02330 * ( init --- )
+ (fig-forth-auto680):02331 * { init VARIABLE name } typical input
+ (fig-forth-auto680):02332 * Use CONSTANT to CREATE a header and compile the initial value, init,
+ (fig-forth-auto680):02333 * then overwrite the characteristic to point to DOVAR.
+1809 88 (fig-forth-auto680):02334 FCB $88
+180A 5641524941424C (fig-forth-auto680):02335 FCC 'VARIABL' ; 'VARIABLE'
+1811 C5 (fig-forth-auto680):02336 FCB $C5
+1812 17F8 (fig-forth-auto680):02337 FDB NATP-7
+1814 17B617DC1C35 (fig-forth-auto680):02338 VAR FDB DOCOL,CON,PSCODE
+ (fig-forth-auto680):02339 * ( --- vadr )
+ (fig-forth-auto680):02340 * Characteristic of a VARIABLE.
+ (fig-forth-auto680):02341 * A VARIABLE pushes its PFA address on the stack.
+ (fig-forth-auto680):02342 * The parameter field of a VARIABLE is the actual allocation of the variable,
+ (fig-forth-auto680):02343 * so that pushing its address allows its contents to be @ed (fetched).
+ (fig-forth-auto680):02344 * Ordinary arrays and strings that do not subscript themselves
+ (fig-forth-auto680):02345 * may be allocated by defining a variable
+ (fig-forth-auto680):02346 * and immediately ALLOTting the remaining needed space.
+ (fig-forth-auto680):02347 * VARIABLES are global to all users,
+ (fig-forth-auto680):02348 * and thus should be hidden in resource monitors, but aren't.
+181A 3002 (fig-forth-auto680):02349 DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters.
+181C 3610 (fig-forth-auto680):02350 PSHU X
+181E 39 (fig-forth-auto680):02351 RTS
+ (fig-forth-auto680):02352 * DOVAR LDA W
+ (fig-forth-auto680):02353 * LDB W+1
+ (fig-forth-auto680):02354 * ADDB #2
+ (fig-forth-auto680):02355 * ADCA #0 A,B now contain the address of the variable
+ (fig-forth-auto680):02356 * JMP PUSHBA
+ (fig-forth-auto680):02357 *
+ (fig-forth-auto680):02358 * ======>> 51 <<
+ (fig-forth-auto680):02359 * ( ub --- )
+ (fig-forth-auto680):02360 * { uboffset USER name } typical input
+ (fig-forth-auto680):02361 * CREATE a header and compile the unsigned byte offset in the per-USER table,
+ (fig-forth-auto680):02362 * then overwrite the header with a call to DOUSER.
+ (fig-forth-auto680):02363 * The USER is entirely responsible for maintaining allocation!
+181F 84 (fig-forth-auto680):02364 FCB $84
+1820 555345 (fig-forth-auto680):02365 FCC 'USE' ; 'USER'
+1823 D2 (fig-forth-auto680):02366 FCB $D2
+1824 1809 (fig-forth-auto680):02367 FDB VAR-11
+1826 17B617DC1C35 (fig-forth-auto680):02368 USER FDB DOCOL,CON,PSCODE
+ (fig-forth-auto680):02369 * ( --- vadr )
+ (fig-forth-auto680):02370 * Characteristic of a per-USER variable.
+ (fig-forth-auto680):02371 * USER variables are similiar to VARIABLEs,
+ (fig-forth-auto680):02372 * but are allocated (by hand!) in the per-user table.
+ (fig-forth-auto680):02373 * A USER variable's parameter field contains its offset in the per-user table.
+182C 1FB8 (fig-forth-auto680):02374 DOUSER TFR DP,A ; Make a pointer to the direct page.
+182E 5F (fig-forth-auto680):02375 CLRB
+ (fig-forth-auto680):02376 * See Alternative -- alternatives start from this point.
+182F E302 (fig-forth-auto680):02377 ADDD NATWID,X ; Add it to the offset to the per-user variable.
+1831 3606 (fig-forth-auto680):02378 PSHU D
+1833 1F01 (fig-forth-auto680):02379 TFR D,X ; Cache the pointer in X for the caller.
+1835 39 (fig-forth-auto680):02380 RTS
+ (fig-forth-auto680):02381 * Hey, the per-user table could actually be larger than 256 bytes!
+ (fig-forth-auto680):02382 * But we knew that. It's just not as esthetic to calculate it this way.
+ (fig-forth-auto680):02383 * Alternative A:
+ (fig-forth-auto680):02384 * LDX NATWID,X ; Keep the offset
+ (fig-forth-auto680):02385 * EXG D,X ; Prepare for EA
+ (fig-forth-auto680):02386 * LEAX D,X
+ (fig-forth-auto680):02387 * PSHU X
+ (fig-forth-auto680):02388 * RTS
+ (fig-forth-auto680):02389 * Alternative B:
+ (fig-forth-auto680):02390 * PSHS Y ; Get Y free for calculations.
+ (fig-forth-auto680):02391 * TFR D,Y ; Y points to the UP base
+ (fig-forth-auto680):02392 * LDD NATWID,X ; Get the offset
+ (fig-forth-auto680):02393 * LEAX D,Y ; Leave the pointer cached in X.
+ (fig-forth-auto680):02394 * PSHU X
+ (fig-forth-auto680):02395 * PULS Y,PC
+ (fig-forth-auto680):02396 *
+ (fig-forth-auto680):02397 * From the 6800 model:
+ (fig-forth-auto680):02398 * DOUSER LDX W get offset into user's table
+ (fig-forth-auto680):02399 * LDA 2,X
+ (fig-forth-auto680):02400 * LDB 3,X
+ (fig-forth-auto680):02401 * ADDB UP+1 add to users base address
+ (fig-forth-auto680):02402 * ADCA UP
+ (fig-forth-auto680):02403 * JMP PUSHBA push address of user's variable
+ (fig-forth-auto680):02404 *
+ (fig-forth-auto680):02405 * ######>> screen 35 <<
+ (fig-forth-auto680):02406 * ======>> 52 <<
+ (fig-forth-auto680):02407 * ( --- 0 )
+1836 81 (fig-forth-auto680):02408 FCB $81
+1837 B0 (fig-forth-auto680):02409 FCB $B0 0
+1838 181F (fig-forth-auto680):02410 FDB USER-7
+183A 17E6 (fig-forth-auto680):02411 ZERO FDB DOCON
+183C 0000 (fig-forth-auto680):02412 FDB 0000
+ (fig-forth-auto680):02413 *
+ (fig-forth-auto680):02414 * ======>> 53 <<
+ (fig-forth-auto680):02415 * ( --- 1 )
+183E 81 (fig-forth-auto680):02416 FCB $81
+183F B1 (fig-forth-auto680):02417 FCB $B1 1
+1840 1836 (fig-forth-auto680):02418 FDB ZERO-4
+1842 17E6 (fig-forth-auto680):02419 ONE FDB DOCON
+1844 0001 (fig-forth-auto680):02420 ONEV FDB 1
+ (fig-forth-auto680):02421 *
+ (fig-forth-auto680):02422 * ======>> 54 <<
+ (fig-forth-auto680):02423 * ( --- 2 )
+1846 81 (fig-forth-auto680):02424 FCB $81
+1847 B2 (fig-forth-auto680):02425 FCB $B2 2
+1848 183E (fig-forth-auto680):02426 FDB ONE-4
+184A 17E6 (fig-forth-auto680):02427 TWO FDB DOCON
+184C 0002 (fig-forth-auto680):02428 TWOV FDB 2
+ (fig-forth-auto680):02429 *
+ (fig-forth-auto680):02430 * ======>> 55 <<
+ (fig-forth-auto680):02431 * ( --- 3 )
+184E 81 (fig-forth-auto680):02432 FCB $81
+184F B3 (fig-forth-auto680):02433 FCB $B3 3
+1850 1846 (fig-forth-auto680):02434 FDB TWO-4
+1852 17E6 (fig-forth-auto680):02435 THREE FDB DOCON
+1854 0003 (fig-forth-auto680):02436 FDB 3
+ (fig-forth-auto680):02437 *
+ (fig-forth-auto680):02438 * ======>> 56 <<
+ (fig-forth-auto680):02439 * ( --- SP )
+ (fig-forth-auto680):02440 * ASCII SPACE character
+1856 82 (fig-forth-auto680):02441 FCB $82
+1857 42 (fig-forth-auto680):02442 FCC 'B' ; 'BL'
+1858 CC (fig-forth-auto680):02443 FCB $CC
+1859 184E (fig-forth-auto680):02444 FDB THREE-4
+185B 17E6 (fig-forth-auto680):02445 BL FDB DOCON ascii blank
+185D 0020 (fig-forth-auto680):02446 FDB $20
+ (fig-forth-auto680):02447 *
+ (fig-forth-auto680):02448 * ======>> 57 <<
+ (fig-forth-auto680):02449 * This really shouldn't be a CONSTANT.
+ (fig-forth-auto680):02450 * ( --- adr )
+ (fig-forth-auto680):02451 * The base of the disk buffer space.
+185F 85 (fig-forth-auto680):02452 FCB $85
+1860 46495253 (fig-forth-auto680):02453 FCC 'FIRS' ; 'FIRST'
+1864 D4 (fig-forth-auto680):02454 FCB $D4
+1865 1856 (fig-forth-auto680):02455 FDB BL-5
+1867 17E6 (fig-forth-auto680):02456 FIRST FDB DOCON
+1869 6BE0 (fig-forth-auto680):02457 FDB BUFBAS
+ (fig-forth-auto680):02458 * FDB MEMEND-528 (132 * NBLK)
+ (fig-forth-auto680):02459 *
+ (fig-forth-auto680):02460 * ======>> 58 <<
+ (fig-forth-auto680):02461 * This really shouldn't be a CONSTANT.
+ (fig-forth-auto680):02462 * ( --- adr )
+ (fig-forth-auto680):02463 * The limit of the disk buffer space.
+186B 85 (fig-forth-auto680):02464 FCB $85
+186C 4C494D49 (fig-forth-auto680):02465 FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
+1870 D4 (fig-forth-auto680):02466 FCB $D4
+1871 185F (fig-forth-auto680):02467 FDB FIRST-8
+1873 17E6 (fig-forth-auto680):02468 LIMIT FDB DOCON
+1875 7000 (fig-forth-auto680):02469 FDB BUFBAS+BUFSZ
+ (fig-forth-auto680):02470 * In 6800 model, was
+ (fig-forth-auto680):02471 * FDB MEMEND
+ (fig-forth-auto680):02472 *
+ (fig-forth-auto680):02473 * ======>> 59 <<
+ (fig-forth-auto680):02474 * ( --- sectorsize )
+ (fig-forth-auto680):02475 * The size, in bytes, of a buffer.
+1877 85 (fig-forth-auto680):02476 FCB $85
+1878 422F4255 (fig-forth-auto680):02477 FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
+187C C6 (fig-forth-auto680):02478 FCB $C6
+187D 186B (fig-forth-auto680):02479 FDB LIMIT-8
+187F 17E6 (fig-forth-auto680):02480 BBUF FDB DOCON
+1881 0100 (fig-forth-auto680):02481 FDB SECTSZ
+ (fig-forth-auto680):02482 * Hardcoded in 6800 model:
+ (fig-forth-auto680):02483 * FDB 128
+ (fig-forth-auto680):02484 *
+ (fig-forth-auto680):02485 * ======>> 60 <<
+ (fig-forth-auto680):02486 * ( --- blocksperscreen )
+ (fig-forth-auto680):02487 * The size, in blocks, of a screen.
+ (fig-forth-auto680):02488 * Should this be the same as NBLK, the number of block buffers maintained?
+1883 85 (fig-forth-auto680):02489 FCB $85
+1884 422F5343 (fig-forth-auto680):02490 FCC 'B/SC' ; 'B/SCR' : (blocks/screen)
+1888 D2 (fig-forth-auto680):02491 FCB $D2
+1889 1877 (fig-forth-auto680):02492 FDB BBUF-8
+188B 17E6 (fig-forth-auto680):02493 BSCR FDB DOCON
+188D 0004 (fig-forth-auto680):02494 FDB SCRSZ/SECTSZ
+ (fig-forth-auto680):02495 * Hardcoded in 6800 model as:
+ (fig-forth-auto680):02496 * FDB 8
+ (fig-forth-auto680):02497 * blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
+ (fig-forth-auto680):02498 *
+ (fig-forth-auto680):02499 * ======>> 61 <<
+ (fig-forth-auto680):02500 * ( n --- adr )
+ (fig-forth-auto680):02501 * Calculate the address of entry (#n/2) in the boot-up parameter table.
+ (fig-forth-auto680):02502 * (Adds the base of the boot-up table to n.)
+188F 87 (fig-forth-auto680):02503 FCB $87
+1890 2B4F52494749 (fig-forth-auto680):02504 FCC '+ORIGI' ; '+ORIGIN'
+1896 CE (fig-forth-auto680):02505 FCB $CE
+1897 1883 (fig-forth-auto680):02506 FDB BSCR-8
+1899 17B61399120016C1 (fig-forth-auto680):02507 PORIG FDB DOCOL,LIT,ORIG,PLUS
+18A1 1662 (fig-forth-auto680):02508 FDB SEMIS
+ (fig-forth-auto680):02509 *
+ (fig-forth-auto680):02510 * ######>> screen 36 <<
+ (fig-forth-auto680):02511 * ======>> 62 <<
+ (fig-forth-auto680):02512 * ( n --- adr )
+ (fig-forth-auto680):02513 * This is the per-task variable recording the initial parameter stack pointer.
+18A3 82 (fig-forth-auto680):02514 FCB $82
+18A4 53 (fig-forth-auto680):02515 FCC 'S' ; 'S0'
+18A5 B0 (fig-forth-auto680):02516 FCB $B0
+18A6 188F (fig-forth-auto680):02517 FDB PORIG-10
+18A8 182C (fig-forth-auto680):02518 SZERO FDB DOUSER
+18AA 001E (fig-forth-auto680):02519 FDB XSPZER-UORIG
+ (fig-forth-auto680):02520 *
+ (fig-forth-auto680):02521 * ======>> 63 <<
+ (fig-forth-auto680):02522 * ( n --- adr )
+ (fig-forth-auto680):02523 * This is the per-task variable recording the initial return stack pointer.
+18AC 82 (fig-forth-auto680):02524 FCB $82
+18AD 52 (fig-forth-auto680):02525 FCC 'R' ; 'R0'
+18AE B0 (fig-forth-auto680):02526 FCB $B0
+18AF 18A3 (fig-forth-auto680):02527 FDB SZERO-5
+18B1 182C (fig-forth-auto680):02528 RZERO FDB DOUSER
+18B3 0020 (fig-forth-auto680):02529 FDB XRZERO-UORIG
+ (fig-forth-auto680):02530 *
+ (fig-forth-auto680):02531 * ======>> 64 <<
+ (fig-forth-auto680):02532 * ( --- vadr )
+ (fig-forth-auto680):02533 * Terminal Input Buffer address.
+ (fig-forth-auto680):02534 * Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
+18B5 83 (fig-forth-auto680):02535 FCB $83
+18B6 5449 (fig-forth-auto680):02536 FCC 'TI' ; 'TIB'
+18B8 C2 (fig-forth-auto680):02537 FCB $C2
+18B9 18AC (fig-forth-auto680):02538 FDB RZERO-5
+18BB 182C (fig-forth-auto680):02539 TIB FDB DOUSER
+18BD 0022 (fig-forth-auto680):02540 FDB XTIB-UORIG
+ (fig-forth-auto680):02541 *
+ (fig-forth-auto680):02542 * ======>> 65 <<
+ (fig-forth-auto680):02543 * ( --- maxnamewidth )
+ (fig-forth-auto680):02544 * This is the maximum width to which symbol names will be recorded.
+18BF 85 (fig-forth-auto680):02545 FCB $85
+18C0 57494454 (fig-forth-auto680):02546 FCC 'WIDT' ; 'WIDTH'
+18C4 C8 (fig-forth-auto680):02547 FCB $C8
+18C5 18B5 (fig-forth-auto680):02548 FDB TIB-6
+18C7 182C (fig-forth-auto680):02549 WIDTH FDB DOUSER
+18C9 0024 (fig-forth-auto680):02550 FDB XWIDTH-UORIG
+ (fig-forth-auto680):02551 *
+ (fig-forth-auto680):02552 * ======>> 66 <<
+ (fig-forth-auto680):02553 * ( --- vadr )
+ (fig-forth-auto680):02554 * Availability of error messages on disk.
+ (fig-forth-auto680):02555 * Contains 1 if messages available,
+ (fig-forth-auto680):02556 * 0 if not,
+ (fig-forth-auto680):02557 * -1 if a disk error has occurred.
+18CB 87 (fig-forth-auto680):02558 FCB $87
+18CC 5741524E494E (fig-forth-auto680):02559 FCC 'WARNIN' ; 'WARNING'
+18D2 C7 (fig-forth-auto680):02560 FCB $C7
+18D3 18BF (fig-forth-auto680):02561 FDB WIDTH-8
+18D5 182C (fig-forth-auto680):02562 WARN FDB DOUSER
+18D7 0026 (fig-forth-auto680):02563 FDB XWARN-UORIG
+ (fig-forth-auto680):02564 *
+ (fig-forth-auto680):02565 * ======>> 67 <<
+ (fig-forth-auto680):02566 * ( --- vadr )
+ (fig-forth-auto680):02567 * Boundary for FORGET.
+18D9 85 (fig-forth-auto680):02568 FCB $85
+18DA 46454E43 (fig-forth-auto680):02569 FCC 'FENC' ; 'FENCE'
+18DE C5 (fig-forth-auto680):02570 FCB $C5
+18DF 18CB (fig-forth-auto680):02571 FDB WARN-10
+18E1 182C (fig-forth-auto680):02572 FENCE FDB DOUSER
+18E3 0028 (fig-forth-auto680):02573 FDB XFENCE-UORIG
+ (fig-forth-auto680):02574 *
+ (fig-forth-auto680):02575 * ======>> 68 <<
+ (fig-forth-auto680):02576 * ( --- vadr )
+ (fig-forth-auto680):02577 * Dictionary pointer, fetched by HERE.
+18E5 82 (fig-forth-auto680):02578 FCB $82
+18E6 44 (fig-forth-auto680):02579 FCC 'D' ; 'DP' : points to first free byte at end of dictionary
+18E7 D0 (fig-forth-auto680):02580 FCB $D0
+18E8 18D9 (fig-forth-auto680):02581 FDB FENCE-8
+18EA 182C (fig-forth-auto680):02582 DICTPT FDB DOUSER
+18EC 002A (fig-forth-auto680):02583 FDB XDICTP-UORIG
+ (fig-forth-auto680):02584 *
+ (fig-forth-auto680):02585 * ======>> 68.5 <<
+ (fig-forth-auto680):02586 * ( --- vadr ) ******* Need to check what this is!
+ (fig-forth-auto680):02587 * Used in maintaining vocabularies.
+ (fig-forth-auto680):02588 * I think it points to the "parent" vocabulary, but I'm not sure.
+ (fig-forth-auto680):02589 * Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
+18EE 88 (fig-forth-auto680):02590 FCB $88
+18EF 564F432D4C494E (fig-forth-auto680):02591 FCC 'VOC-LIN' ; 'VOC-LINK'
+18F6 CB (fig-forth-auto680):02592 FCB $CB
+18F7 18E5 (fig-forth-auto680):02593 FDB DICTPT-5
+18F9 182C (fig-forth-auto680):02594 VOCLIN FDB DOUSER
+18FB 002C (fig-forth-auto680):02595 FDB XVOCL-UORIG
+ (fig-forth-auto680):02596 *
+ (fig-forth-auto680):02597 * ======>> 69 <<
+ (fig-forth-auto680):02598 * ( --- vadr )
+ (fig-forth-auto680):02599 * Disk block being interpreted.
+ (fig-forth-auto680):02600 * Zero refers to terminal.
+ (fig-forth-auto680):02601 * ******** Should be made a 32 bit user variable! ********
+ (fig-forth-auto680):02602 * But the base system needs to have full 32 bit support, div and mul, etc.
+ (fig-forth-auto680):02603 * before we can do that.
+18FD 83 (fig-forth-auto680):02604 FCB $83
+18FE 424C (fig-forth-auto680):02605 FCC 'BL' ; 'BLK'
+1900 CB (fig-forth-auto680):02606 FCB $CB
+1901 18EE (fig-forth-auto680):02607 FDB VOCLIN-11
+1903 182C (fig-forth-auto680):02608 BLK FDB DOUSER
+1905 002E (fig-forth-auto680):02609 FDB XBLK-UORIG
+ (fig-forth-auto680):02610 *
+ (fig-forth-auto680):02611 * ======>> 70 <<
+ (fig-forth-auto680):02612 * ( --- vadr )
+ (fig-forth-auto680):02613 * Input buffer offset/cursor.
+1907 82 (fig-forth-auto680):02614 FCB $82
+1908 49 (fig-forth-auto680):02615 FCC 'I' ; 'IN' : scan pointer for input line buffer
+1909 CE (fig-forth-auto680):02616 FCB $CE
+190A 18FD (fig-forth-auto680):02617 FDB BLK-6
+190C 182C (fig-forth-auto680):02618 IN FDB DOUSER
+190E 0030 (fig-forth-auto680):02619 FDB XIN-UORIG
+ (fig-forth-auto680):02620 *
+ (fig-forth-auto680):02621 * ======>> 71 <<
+ (fig-forth-auto680):02622 * ( --- vadr )
+ (fig-forth-auto680):02623 * Output buffer offset/cursor.
+1910 83 (fig-forth-auto680):02624 FCB $83
+1911 4F55 (fig-forth-auto680):02625 FCC 'OU' ; 'OUT'
+1913 D4 (fig-forth-auto680):02626 FCB $D4
+1914 1907 (fig-forth-auto680):02627 FDB IN-5
+1916 182C (fig-forth-auto680):02628 OUT FDB DOUSER
+1918 0032 (fig-forth-auto680):02629 FDB XOUT-UORIG
+ (fig-forth-auto680):02630 *
+ (fig-forth-auto680):02631 * ======>> 72 <<
+ (fig-forth-auto680):02632 * ( --- vadr )
+ (fig-forth-auto680):02633 * Screen currently being edited, once we have an editor running.
+191A 83 (fig-forth-auto680):02634 FCB $83
+191B 5343 (fig-forth-auto680):02635 FCC 'SC' ; 'SCR'
+191D D2 (fig-forth-auto680):02636 FCB $D2
+191E 1910 (fig-forth-auto680):02637 FDB OUT-6
+1920 182C (fig-forth-auto680):02638 SCR FDB DOUSER
+1922 0034 (fig-forth-auto680):02639 FDB XSCR-UORIG
+ (fig-forth-auto680):02640 * ######>> screen 37 <<
+ (fig-forth-auto680):02641 *
+ (fig-forth-auto680):02642 * ======>> 73 <<
+ (fig-forth-auto680):02643 * ( --- vadr )
+ (fig-forth-auto680):02644 * Sector offset for LOADing screens,
+ (fig-forth-auto680):02645 * set by DRIVE to make a new drive the default.
+ (fig-forth-auto680):02646 * This should also be 32 bit or bigger.
+1924 86 (fig-forth-auto680):02647 FCB $86
+1925 4F46465345 (fig-forth-auto680):02648 FCC 'OFFSE' ; 'OFFSET'
+192A D4 (fig-forth-auto680):02649 FCB $D4
+192B 191A (fig-forth-auto680):02650 FDB SCR-6
+192D 182C (fig-forth-auto680):02651 OFSET FDB DOUSER
+192F 0036 (fig-forth-auto680):02652 FDB XOFSET-UORIG
+ (fig-forth-auto680):02653 *
+ (fig-forth-auto680):02654 * ======>> 74 <<
+ (fig-forth-auto680):02655 * ( --- vadr )
+ (fig-forth-auto680):02656 * Current context of interpretation (vocabulary root).
+1931 87 (fig-forth-auto680):02657 FCB $87
+1932 434F4E544558 (fig-forth-auto680):02658 FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
+1938 D4 (fig-forth-auto680):02659 FCB $D4
+1939 1924 (fig-forth-auto680):02660 FDB OFSET-9
+193B 182C (fig-forth-auto680):02661 CONTXT FDB DOUSER
+193D 0038 (fig-forth-auto680):02662 FDB XCONT-UORIG
+ (fig-forth-auto680):02663 *
+ (fig-forth-auto680):02664 * ======>> 75 <<
+ (fig-forth-auto680):02665 * ( --- vadr )
+ (fig-forth-auto680):02666 * Current context of definition (vocabulary root).
+193F 87 (fig-forth-auto680):02667 FCB $87
+1940 43555252454E (fig-forth-auto680):02668 FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
+1946 D4 (fig-forth-auto680):02669 FCB $D4
+1947 1931 (fig-forth-auto680):02670 FDB CONTXT-10
+1949 182C (fig-forth-auto680):02671 CURENT FDB DOUSER
+194B 003A (fig-forth-auto680):02672 FDB XCURR-UORIG
+ (fig-forth-auto680):02673 *
+ (fig-forth-auto680):02674 * ======>> 76 <<
+ (fig-forth-auto680):02675 * ( --- vadr )
+ (fig-forth-auto680):02676 * Compiler/interpreter state.
+194D 85 (fig-forth-auto680):02677 FCB $85
+194E 53544154 (fig-forth-auto680):02678 FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
+1952 C5 (fig-forth-auto680):02679 FCB $C5
+1953 193F (fig-forth-auto680):02680 FDB CURENT-10
+1955 182C (fig-forth-auto680):02681 STATE FDB DOUSER
+1957 003C (fig-forth-auto680):02682 FDB XSTATE-UORIG
+ (fig-forth-auto680):02683 *
+ (fig-forth-auto680):02684 * ======>> 77 <<
+ (fig-forth-auto680):02685 * ( --- vadr )
+ (fig-forth-auto680):02686 * Numeric conversion base.
+1959 84 (fig-forth-auto680):02687 FCB $84
+195A 424153 (fig-forth-auto680):02688 FCC 'BAS' ; 'BASE' : number base for all input & output
+195D C5 (fig-forth-auto680):02689 FCB $C5
+195E 194D (fig-forth-auto680):02690 FDB STATE-8
+1960 182C (fig-forth-auto680):02691 BASE FDB DOUSER
+1962 003E (fig-forth-auto680):02692 FDB XBASE-UORIG
+ (fig-forth-auto680):02693 *
+ (fig-forth-auto680):02694 * ======>> 78 <<
+ (fig-forth-auto680):02695 * ( --- vadr )
+ (fig-forth-auto680):02696 * Decimal point location for output.
+1964 83 (fig-forth-auto680):02697 FCB $83
+1965 4450 (fig-forth-auto680):02698 FCC 'DP' ; 'DPL'
+1967 CC (fig-forth-auto680):02699 FCB $CC
+1968 1959 (fig-forth-auto680):02700 FDB BASE-7
+196A 182C (fig-forth-auto680):02701 DPL FDB DOUSER
+196C 0040 (fig-forth-auto680):02702 FDB XDPL-UORIG
+ (fig-forth-auto680):02703 *
+ (fig-forth-auto680):02704 * ======>> 79 <<
+ (fig-forth-auto680):02705 * ( --- vadr )
+ (fig-forth-auto680):02706 * Field width for I/O formatting.
+196E 83 (fig-forth-auto680):02707 FCB $83
+196F 464C (fig-forth-auto680):02708 FCC 'FL' ; 'FLD'
+1971 C4 (fig-forth-auto680):02709 FCB $C4
+1972 1964 (fig-forth-auto680):02710 FDB DPL-6
+1974 182C (fig-forth-auto680):02711 FLD FDB DOUSER
+1976 0042 (fig-forth-auto680):02712 FDB XFLD-UORIG
+ (fig-forth-auto680):02713 *
+ (fig-forth-auto680):02714 * ======>> 80 <<
+ (fig-forth-auto680):02715 * ( --- vadr )
+ (fig-forth-auto680):02716 * Compiler stack mark for stack check.
+1978 83 (fig-forth-auto680):02717 FCB $83
+1979 4353 (fig-forth-auto680):02718 FCC 'CS' ; 'CSP'
+197B D0 (fig-forth-auto680):02719 FCB $D0
+197C 196E (fig-forth-auto680):02720 FDB FLD-6
+197E 182C (fig-forth-auto680):02721 CSP FDB DOUSER
+1980 0044 (fig-forth-auto680):02722 FDB XCSP-UORIG
+ (fig-forth-auto680):02723 *
+ (fig-forth-auto680):02724 * ======>> 81 <<
+ (fig-forth-auto680):02725 * ( --- vadr )
+ (fig-forth-auto680):02726 * Editing cursor location.
+1982 82 (fig-forth-auto680):02727 FCB $82
+1983 52 (fig-forth-auto680):02728 FCC 'R' ; 'R#'
+1984 A3 (fig-forth-auto680):02729 FCB $A3
+1985 1978 (fig-forth-auto680):02730 FDB CSP-6
+1987 182C (fig-forth-auto680):02731 RNUM FDB DOUSER
+1989 0046 (fig-forth-auto680):02732 FDB XRNUM-UORIG
+ (fig-forth-auto680):02733 *
+ (fig-forth-auto680):02734 * ======>> 82 <<
+ (fig-forth-auto680):02735 * ( --- vadr )
+ (fig-forth-auto680):02736 * Pointer to last HELD character in PAD.
+198B 83 (fig-forth-auto680):02737 FCB $83
+198C 484C (fig-forth-auto680):02738 FCC 'HL' ; 'HLD'
+198E C4 (fig-forth-auto680):02739 FCB $C4
+198F 1982 (fig-forth-auto680):02740 FDB RNUM-5
+1991 17E6 (fig-forth-auto680):02741 HLD FDB DOCON
+1993 7C48 (fig-forth-auto680):02742 FDB XHLD
+ (fig-forth-auto680):02743 *
+ (fig-forth-auto680):02744 * ======>> 82.5 <<== SPECIAL
+ (fig-forth-auto680):02745 * ( --- vadr )
+ (fig-forth-auto680):02746 * Line width of active terminal.
+1995 87 (fig-forth-auto680):02747 FCB $87
+1996 434F4C554D4E (fig-forth-auto680):02748 FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
+199C D3 (fig-forth-auto680):02749 FCB $D3
+199D 198B (fig-forth-auto680):02750 FDB HLD-6
+199F 182C (fig-forth-auto680):02751 COLUMS FDB DOUSER
+19A1 004C (fig-forth-auto680):02752 FDB XCOLUM-UORIG
+ (fig-forth-auto680):02753 *
+ (fig-forth-auto680):02754 * ######>> screen 38 <<
+ (fig-forth-auto680):02755 **
+ (fig-forth-auto680):02756 ** An INCREMENTER probably should not be defined without a defined CONSTANT?
+ (fig-forth-auto680):02757 **
+ (fig-forth-auto680):02758 ** Make an INCREMENTER compiling word (not in model):
+ (fig-forth-auto680):02759 ** ( n --- )
+ (fig-forth-auto680):02760 ** { n INCREMENTER name } typical input
+ (fig-forth-auto680):02761 ** CREATE a header and compile the increment constant,
+ (fig-forth-auto680):02762 ** then overwrite the header with a call to DOINC.
+ (fig-forth-auto680):02763 * FCB $8B
+ (fig-forth-auto680):02764 * FCC 'INCREMENTE' ; 'INCREMENTER'
+ (fig-forth-auto680):02765 * FCB $D2
+ (fig-forth-auto680):02766 * FDB COLUMS-10
+ (fig-forth-auto680):02767 * INCR FDB DOCOL,CON,PSCODE
+ (fig-forth-auto680):02768 ** ( n --- ninc )
+ (fig-forth-auto680):02769 ** Characteristic of an INCREMENTER.
+ (fig-forth-auto680):02770 ** This is too naive:
+ (fig-forth-auto680):02771 * DOINC LDD ,U
+ (fig-forth-auto680):02772 * ADDD NATWID,X ; Add the increment.
+ (fig-forth-auto680):02773 * STD ,U
+ (fig-forth-auto680):02774 * RTS
+ (fig-forth-auto680):02775 * Compiling word should check that it is compiling a CONSTANT.
+ (fig-forth-auto680):02776 *
+ (fig-forth-auto680):02777 * ======>> 83 <<
+ (fig-forth-auto680):02778 * ( n --- n+1 )
+19A3 82 (fig-forth-auto680):02779 FCB $82
+19A4 31 (fig-forth-auto680):02780 FCC '1' ; '1+'
+19A5 AB (fig-forth-auto680):02781 FCB $AB
+19A6 1995 (fig-forth-auto680):02782 FDB COLUMS-10
+ (fig-forth-auto680):02783 * Using the model keeps things semantically connected for other processors:
+19A8 17B6184216C1 (fig-forth-auto680):02784 ONEP FDB DOCOL,ONE,PLUS
+19AE 1662 (fig-forth-auto680):02785 FDB SEMIS
+ (fig-forth-auto680):02786 ** Greedy alternative:
+ (fig-forth-auto680):02787 * ONEP FDB *+NATWID
+ (fig-forth-auto680):02788 * LDD ,U
+ (fig-forth-auto680):02789 * ADDD ONEV,PCR
+ (fig-forth-auto680):02790 * STD ,U
+ (fig-forth-auto680):02791 * RTS
+ (fig-forth-auto680):02792 * Naive alternative:
+ (fig-forth-auto680):02793 * ONEP FDB DOINC
+ (fig-forth-auto680):02794 * FDB 1
+ (fig-forth-auto680):02795 * Naive alternative:
+ (fig-forth-auto680):02796 * ONEP FDB *+NATWID
+ (fig-forth-auto680):02797 * LDD ,U
+ (fig-forth-auto680):02798 * ADDD #1 ; It's hard to imagine 1+ being other than 1.
+ (fig-forth-auto680):02799 * STD ,U
+ (fig-forth-auto680):02800 * RTS
+ (fig-forth-auto680):02801 *
+ (fig-forth-auto680):02802 * ======>> 84 <<
+ (fig-forth-auto680):02803 * ( n --- n+2 )
+19B0 82 (fig-forth-auto680):02804 FCB $82
+19B1 32 (fig-forth-auto680):02805 FCC '2' ; '2+'
+19B2 AB (fig-forth-auto680):02806 FCB $AB
+19B3 19A3 (fig-forth-auto680):02807 FDB ONEP-5
+ (fig-forth-auto680):02808 * Using the model keeps things semantically connected for other processors:
+19B5 17B6184A16C1 (fig-forth-auto680):02809 TWOP FDB DOCOL,TWO,PLUS
+19BB 1662 (fig-forth-auto680):02810 FDB SEMIS
+ (fig-forth-auto680):02811 ** Greedy alternative:
+ (fig-forth-auto680):02812 * TWOP FDB *+NATWID
+ (fig-forth-auto680):02813 * LDD ,U
+ (fig-forth-auto680):02814 * ADDD TWOV,PCR ; See NAT+ (NATP)
+ (fig-forth-auto680):02815 * STD ,U
+ (fig-forth-auto680):02816 * RTS
+ (fig-forth-auto680):02817 * Naive alternative:
+ (fig-forth-auto680):02818 * TWOP FDB DOINC
+ (fig-forth-auto680):02819 * FDB 2
+ (fig-forth-auto680):02820 * Naive alternative:
+ (fig-forth-auto680):02821 * TWOP FDB *+NATWID
+ (fig-forth-auto680):02822 * LDD ,U
+ (fig-forth-auto680):02823 * ADDD #2 ; See NAT+ (NATP)
+ (fig-forth-auto680):02824 * STD ,U
+ (fig-forth-auto680):02825 * RTS
+ (fig-forth-auto680):02826 *
+ (fig-forth-auto680):02827 * ======>> 85 <<
+ (fig-forth-auto680):02828 * ( --- adr )
+ (fig-forth-auto680):02829 * Get the DICTPT allocation, like a USER constant.
+ (fig-forth-auto680):02830 * Should check the stack and heap for collision.
+19BD 84 (fig-forth-auto680):02831 FCB $84
+19BE 484552 (fig-forth-auto680):02832 FCC 'HER' ; 'HERE'
+19C1 C5 (fig-forth-auto680):02833 FCB $C5
+19C2 19B0 (fig-forth-auto680):02834 FDB TWOP-5
+19C4 17B618EA176F (fig-forth-auto680):02835 HERE FDB DOCOL,DICTPT,AT
+19CA 1662 (fig-forth-auto680):02836 FDB SEMIS
+ (fig-forth-auto680):02837 *
+ (fig-forth-auto680):02838 * ======>> 86 <<
+ (fig-forth-auto680):02839 * ( n --- )
+ (fig-forth-auto680):02840 * Increase/decrease heap (add n to DP),
+ (fig-forth-auto680):02841 * Should ERROR check stack/heap.
+19CC 85 (fig-forth-auto680):02842 FCB $85
+19CD 414C4C4F (fig-forth-auto680):02843 FCC 'ALLO' ; 'ALLOT'
+19D1 D4 (fig-forth-auto680):02844 FCB $D4
+19D2 19BD (fig-forth-auto680):02845 FDB HERE-7
+19D4 17B618EA174E (fig-forth-auto680):02846 ALLOT FDB DOCOL,DICTPT,PSTORE
+19DA 1662 (fig-forth-auto680):02847 FDB SEMIS
+ (fig-forth-auto680):02848 *
+ (fig-forth-auto680):02849 * ======>> 87 <<
+ (fig-forth-auto680):02850 * ( n --- )
+ (fig-forth-auto680):02851 * Store word n at DP++,
+ (fig-forth-auto680):02852 * Should ERROR check stack/heap.
+19DC 81 (fig-forth-auto680):02853 FCB $81 ; , (COMMA)
+19DD AC (fig-forth-auto680):02854 FCB $AC
+19DE 19CC (fig-forth-auto680):02855 FDB ALLOT-8
+19E0 17B619C4178717F4 (fig-forth-auto680):02856 COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT
+ 19D4
+19EA 1662 (fig-forth-auto680):02857 FDB SEMIS
+ (fig-forth-auto680):02858 * COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
+ (fig-forth-auto680):02859 * FDB SEMIS
+ (fig-forth-auto680):02860 *
+ (fig-forth-auto680):02861 * ======>> 88 <<
+ (fig-forth-auto680):02862 * ( b --- )
+ (fig-forth-auto680):02863 * Store byte b at DP+,
+ (fig-forth-auto680):02864 * Should ERROR check stack/heap.
+19EC 82 (fig-forth-auto680):02865 FCB $82
+19ED 43 (fig-forth-auto680):02866 FCC 'C' ; 'C,'
+19EE AC (fig-forth-auto680):02867 FCB $AC
+19EF 19DC (fig-forth-auto680):02868 FDB COMMA-4
+19F1 17B619C417951842 (fig-forth-auto680):02869 CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
+ 19D4
+19FB 1662 (fig-forth-auto680):02870 FDB SEMIS
+ (fig-forth-auto680):02871 *
+ (fig-forth-auto680):02872 * ======>> 89 <<
+ (fig-forth-auto680):02873 * ( n1 n2 --- n1-n2 )
+ (fig-forth-auto680):02874 * Subtract top two words.
+19FD 81 (fig-forth-auto680):02875 FCB $81 ; -
+19FE AD (fig-forth-auto680):02876 FCB $AD
+19FF 19EC (fig-forth-auto680):02877 FDB CCOMM-5
+1A01 1A03 (fig-forth-auto680):02878 SUB FDB *+NATWID
+1A03 EC42 (fig-forth-auto680):02879 LDD NATWID,U ; #2~6
+1A05 A3C1 (fig-forth-auto680):02880 SUBD ,U++ ; #2~9
+1A07 EDC4 (fig-forth-auto680):02881 STD ,U ; #2~5
+1A09 39 (fig-forth-auto680):02882 RTS ; #1~5 = #7~25
+ (fig-forth-auto680):02883 * SUB FDB DOCOL,MINUS,PLUS
+ (fig-forth-auto680):02884 * FDB SEMIS ; Costs 6 bytes and lots of cycles.
+ (fig-forth-auto680):02885 *
+ (fig-forth-auto680):02886 * ======>> 90 <<
+ (fig-forth-auto680):02887 * ( n1 n2 --- n1==n2 )
+ (fig-forth-auto680):02888 * Return flag true if n1 and n2 are equal, otherwise false.
+1A0A 81 (fig-forth-auto680):02889 FCB $81 =
+1A0B BD (fig-forth-auto680):02890 FCB $BD
+1A0C 19FD (fig-forth-auto680):02891 FDB SUB-4
+1A0E 17B61A01169E (fig-forth-auto680):02892 EQUAL FDB DOCOL,SUB,ZEQU
+1A14 1662 (fig-forth-auto680):02893 FDB SEMIS
+ (fig-forth-auto680):02894 *
+ (fig-forth-auto680):02895 * ======>> 91 <<
+ (fig-forth-auto680):02896 * ( n1 n2 --- n1<n2 )
+ (fig-forth-auto680):02897 * Return flag true if n1 is less than n2, otherwise false.
+1A16 81 (fig-forth-auto680):02898 FCB $81 <
+1A17 BC (fig-forth-auto680):02899 FCB $BC
+1A18 1A0A (fig-forth-auto680):02900 FDB EQUAL-4
+1A1A 1A1C (fig-forth-auto680):02901 LESS FDB *+NATWID
+1A1C EC42 (fig-forth-auto680):02902 LDD NATWID,U
+1A1E A3C1 (fig-forth-auto680):02903 SUBD ,U++
+1A20 2C06 (fig-forth-auto680):02904 BGE FALSE
+1A22 CC0001 (fig-forth-auto680):02905 TRUE LDD #1
+1A25 EDC4 (fig-forth-auto680):02906 STD ,U
+1A27 39 (fig-forth-auto680):02907 RTS
+1A28 CC0000 (fig-forth-auto680):02908 FALSE LDD #0
+1A2B EDC4 (fig-forth-auto680):02909 STD ,U
+1A2D 39 (fig-forth-auto680):02910 RTS
+ (fig-forth-auto680):02911 * PULS A ;
+ (fig-forth-auto680):02912 * PULS B ;
+ (fig-forth-auto680):02913 * TFR S,X ; TSX :
+ (fig-forth-auto680):02914 * CMPA 0,X
+ (fig-forth-auto680):02915 * LEAS 1,S ;
+ (fig-forth-auto680):02916 * BGT LESST
+ (fig-forth-auto680):02917 * BNE LESSF
+ (fig-forth-auto680):02918 * CMPB 1,X ; Why not sub, sbc, bge?
+ (fig-forth-auto680):02919 * BHI LESST
+ (fig-forth-auto680):02920 * LESSF CLRB ;
+ (fig-forth-auto680):02921 * BRA LESSX
+ (fig-forth-auto680):02922 * LESST LDB #1
+ (fig-forth-auto680):02923 * LESSX CLRA ;
+ (fig-forth-auto680):02924 * LEAS 1,S ;
+ (fig-forth-auto680):02925 * JMP PUSHBA
+ (fig-forth-auto680):02926 *
+ (fig-forth-auto680):02927 * ======>> 92 <<
+ (fig-forth-auto680):02928 * ( n1 n2 --- n1>n2 )
+ (fig-forth-auto680):02929 * Return flag true if n1 is greater than n2, false otherwise.
+1A2E 81 (fig-forth-auto680):02930 FCB $81 >
+1A2F BE (fig-forth-auto680):02931 FCB $BE
+1A30 1A16 (fig-forth-auto680):02932 FDB LESS-4
+1A32 17B617331A1A (fig-forth-auto680):02933 GREAT FDB DOCOL,SWAP,LESS
+1A38 1662 (fig-forth-auto680):02934 FDB SEMIS
+ (fig-forth-auto680):02935 *
+ (fig-forth-auto680):02936 * ======>> 93 <<
+ (fig-forth-auto680):02937 * ( n1 n2 n3 --- n2 n3 n1 )
+ (fig-forth-auto680):02938 * Rotate the top three words on stack,
+ (fig-forth-auto680):02939 * bringing the third word to the top.
+1A3A 83 (fig-forth-auto680):02940 FCB $83
+1A3B 524F (fig-forth-auto680):02941 FCC 'RO' ; 'ROT'
+1A3D D4 (fig-forth-auto680):02942 FCB $D4
+1A3E 1A2E (fig-forth-auto680):02943 FDB GREAT-4
+1A40 1A42 (fig-forth-auto680):02944 ROT FDB *+NATWID
+1A42 3420 (fig-forth-auto680):02945 PSHS Y
+1A44 3736 (fig-forth-auto680):02946 PULU D,X,Y
+1A46 3616 (fig-forth-auto680):02947 PSHU D,X
+1A48 3620 (fig-forth-auto680):02948 PSHU Y
+1A4A 35A0 (fig-forth-auto680):02949 PULS Y,PC
+ (fig-forth-auto680):02950 * ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
+ (fig-forth-auto680):02951 * FDB SEMIS
+ (fig-forth-auto680):02952 *
+ (fig-forth-auto680):02953 * ======>> 94 <<
+ (fig-forth-auto680):02954 * ( --- )
+ (fig-forth-auto680):02955 * EMIT a SPACE.
+1A4C 85 (fig-forth-auto680):02956 FCB $85
+1A4D 53504143 (fig-forth-auto680):02957 FCC 'SPAC' ; 'SPACE'
+1A51 C5 (fig-forth-auto680):02958 FCB $C5
+1A52 1A3A (fig-forth-auto680):02959 FDB ROT-6
+1A54 17B6185B1541 (fig-forth-auto680):02960 SPACE FDB DOCOL,BL,EMIT
+1A5A 1662 (fig-forth-auto680):02961 FDB SEMIS
+ (fig-forth-auto680):02962 *
+ (fig-forth-auto680):02963 * ======>> 95 <<
+ (fig-forth-auto680):02964 * ( n0 n1 --- min(n0,n1) )
+ (fig-forth-auto680):02965 * Leave the minimum of the top two integers.
+ (fig-forth-auto680):02966 * Being too greedy here, but, whatever.
+1A5C 83 (fig-forth-auto680):02967 FCB $83
+1A5D 4D49 (fig-forth-auto680):02968 FCC 'MI' ; 'MIN'
+1A5F CE (fig-forth-auto680):02969 FCB $CE
+1A60 1A4C (fig-forth-auto680):02970 FDB SPACE-8
+1A62 1A64 (fig-forth-auto680):02971 MIN FDB *+NATWID
+1A64 3706 (fig-forth-auto680):02972 PULU D
+1A66 10A3C4 (fig-forth-auto680):02973 CMPD ,U
+1A69 2F02 (fig-forth-auto680):02974 BLE MINX
+1A6B EDC4 (fig-forth-auto680):02975 STD ,U
+1A6D 39 (fig-forth-auto680):02976 MINX RTS
+ (fig-forth-auto680):02977 * MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
+ (fig-forth-auto680):02978 * FDB MIN2-*-NATWID
+ (fig-forth-auto680):02979 * FDB SWAP
+ (fig-forth-auto680):02980 * MIN2 FDB DROP
+ (fig-forth-auto680):02981 * FDB SEMIS
+ (fig-forth-auto680):02982 *
+ (fig-forth-auto680):02983 * ======>> 96 <<
+ (fig-forth-auto680):02984 * ( n0 n1 --- max(n0,n1) )
+ (fig-forth-auto680):02985 * Leave the maximum of the top two integers.
+ (fig-forth-auto680):02986 * Really should leave this as in the model.
+1A6E 83 (fig-forth-auto680):02987 FCB $83
+1A6F 4D41 (fig-forth-auto680):02988 FCC 'MA' ; 'MAX'
+1A71 D8 (fig-forth-auto680):02989 FCB $D8
+1A72 1A5C (fig-forth-auto680):02990 FDB MIN-6
+1A74 1A76 (fig-forth-auto680):02991 MAX FDB *+NATWID
+1A76 3706 (fig-forth-auto680):02992 PULU D
+1A78 10A3C4 (fig-forth-auto680):02993 CMPD ,U
+1A7B 2F02 (fig-forth-auto680):02994 BLE MAXX
+1A7D EDC4 (fig-forth-auto680):02995 STD ,U
+1A7F 39 (fig-forth-auto680):02996 MAXX RTS
+ (fig-forth-auto680):02997 * MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
+ (fig-forth-auto680):02998 * FDB MAX2-*-NATWID
+ (fig-forth-auto680):02999 * FDB SWAP
+ (fig-forth-auto680):03000 * MAX2 FDB DROP
+ (fig-forth-auto680):03001 * FDB SEMIS
+ (fig-forth-auto680):03002 *
+ (fig-forth-auto680):03003 * ======>> 97 <<
+ (fig-forth-auto680):03004 * ( 0 --- 0 )
+ (fig-forth-auto680):03005 * ( n --- n n )
+ (fig-forth-auto680):03006 * DUP if non-zero.
+1A80 84 (fig-forth-auto680):03007 FCB $84
+1A81 2D4455 (fig-forth-auto680):03008 FCC '-DU' ; '-DUP'
+1A84 D0 (fig-forth-auto680):03009 FCB $D0
+1A85 1A6E (fig-forth-auto680):03010 FDB MAX-6
+1A87 1A89 (fig-forth-auto680):03011 DDUP FDB *+NATWID
+1A89 ECC4 (fig-forth-auto680):03012 LDD ,U
+1A8B 2702 (fig-forth-auto680):03013 BEQ DDUPX
+1A8D 3606 (fig-forth-auto680):03014 PSHU D
+1A8F 39 (fig-forth-auto680):03015 DDUPX RTS
+ (fig-forth-auto680):03016 * DDUP FDB DOCOL,DUP,ZBRAN
+ (fig-forth-auto680):03017 * FDB DDUP2-*-NATWID
+ (fig-forth-auto680):03018 * FDB DUP
+ (fig-forth-auto680):03019 * DDUP2 FDB SEMIS
+ (fig-forth-auto680):03020 *
+ (fig-forth-auto680):03021 * ######>> screen 39 <<
+ (fig-forth-auto680):03022 * ======>> 98.1 <<
+ (fig-forth-auto680):03023 * Supplemental:
+ (fig-forth-auto680):03024 * ( n<0 --- -1 )
+ (fig-forth-auto680):03025 * ( n>=~ --- 1 )
+ (fig-forth-auto680):03026 * Change top integer to its sign.
+1A90 86 (fig-forth-auto680):03027 FCB $86
+1A91 5349474E55 (fig-forth-auto680):03028 FCC 'SIGNU' ; 'SIGNUM'
+1A96 CD (fig-forth-auto680):03029 FCB $CD
+1A97 1A80 (fig-forth-auto680):03030 FDB DDUP-7
+1A99 1A9B (fig-forth-auto680):03031 SIGNUM FDB *+NATWID
+1A9B C601 (fig-forth-auto680):03032 SIGNUE LDB #1
+1A9D A6C4 (fig-forth-auto680):03033 LDA ,U
+1A9F 2A01 (fig-forth-auto680):03034 BPL SIGNUP
+1AA1 50 (fig-forth-auto680):03035 NEGB
+1AA2 1D (fig-forth-auto680):03036 SIGNUP SEX ; Couldn't they have called SignEXtend EXT instead?
+1AA3 EDC4 (fig-forth-auto680):03037 STD ,U ; Am I too much of a prude?
+1AA5 39 (fig-forth-auto680):03038 RTS
+ (fig-forth-auto680):03039 * 6800 model version should be something like this:
+ (fig-forth-auto680):03040 * LDB #1
+ (fig-forth-auto680):03041 * CLRA
+ (fig-forth-auto680):03042 * TSX
+ (fig-forth-auto680):03043 * TST ,X
+ (fig-forth-auto680):03044 * BPL SIGNUP
+ (fig-forth-auto680):03045 * NEGB
+ (fig-forth-auto680):03046 * COMA
+ (fig-forth-auto680):03047 * SIGNUP JMP STABX
+ (fig-forth-auto680):03048 *
+ (fig-forth-auto680):03049 * ======>> 98 <<
+ (fig-forth-auto680):03050 * ( adr1 direction --- adr2 )
+ (fig-forth-auto680):03051 * TRAVERSE the symbol name.
+ (fig-forth-auto680):03052 * If direction is 1, find the end.
+ (fig-forth-auto680):03053 * If direction is -1, find the beginning.
+1AA6 88 (fig-forth-auto680):03054 FCB $88
+1AA7 54524156455253 (fig-forth-auto680):03055 FCC 'TRAVERS' ; 'TRAVERSE'
+1AAE C5 (fig-forth-auto680):03056 FCB $C5
+1AAF 1A90 (fig-forth-auto680):03057 FDB SIGNUM-9
+1AB1 1AB3 (fig-forth-auto680):03058 TRAV FDB *+NATWID
+1AB3 8DE6 (fig-forth-auto680):03059 BSR SIGNUE ; Convert negative to -, zero or positive to 1.
+1AB5 ECC1 (fig-forth-auto680):03060 LDD ,U++ ; Still in D, but we have to pop it anyway.
+1AB7 AEC4 (fig-forth-auto680):03061 LDX ,U ; If D is 1 or -1, so is B.
+1AB9 867F (fig-forth-auto680):03062 LDA #$7F
+1ABB 3085 (fig-forth-auto680):03063 TRAVLP LEAX B,X ; Don't look at the one we start at.
+1ABD A184 (fig-forth-auto680):03064 CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL.
+1ABF 24FA (fig-forth-auto680):03065 BCC TRAVLP
+1AC1 AFC4 (fig-forth-auto680):03066 TRAVDN STX ,U
+1AC3 39 (fig-forth-auto680):03067 RTS
+ (fig-forth-auto680):03068 * Doing this in 6809 just because it can be done may be getting too greedy.
+ (fig-forth-auto680):03069 * TRAV FDB DOCOL,SWAP
+ (fig-forth-auto680):03070 * TRAV2 FDB OVER,PLUS,LIT8
+ (fig-forth-auto680):03071 * FCB $7F
+ (fig-forth-auto680):03072 * FDB OVER,CAT,LESS,ZBRAN
+ (fig-forth-auto680):03073 * FDB TRAV2-*-NATWID
+ (fig-forth-auto680):03074 * FDB SWAP,DROP
+ (fig-forth-auto680):03075 * FDB SEMIS
+ (fig-forth-auto680):03076 *
+ (fig-forth-auto680):03077 * ======>> 99 <<
+ (fig-forth-auto680):03078 * ( --- symptr )
+ (fig-forth-auto680):03079 * Fetch CURRENT as a per-USER constant.
+1AC4 86 (fig-forth-auto680):03080 FCB $86
+1AC5 4C41544553 (fig-forth-auto680):03081 FCC 'LATES' ; 'LATEST'
+1ACA D4 (fig-forth-auto680):03082 FCB $D4
+1ACB 1AA6 (fig-forth-auto680):03083 FDB TRAV-11
+1ACD 17B61949176F176F (fig-forth-auto680):03084 LATEST FDB DOCOL,CURENT,AT,AT
+1AD5 1662 (fig-forth-auto680):03085 FDB SEMIS
+ (fig-forth-auto680):03086 * LATEST FDB *+NATWID
+ (fig-forth-auto680):03087 * Getting too greedy:
+ (fig-forth-auto680):03088 * Version 1:
+ (fig-forth-auto680):03089 * TFR DP,A
+ (fig-forth-auto680):03090 * CLRB
+ (fig-forth-auto680):03091 * TFR D,X
+ (fig-forth-auto680):03092 * LDD CURENT+NATWID,PCR
+ (fig-forth-auto680):03093 * LDX [D,X]
+ (fig-forth-auto680):03094 * PSHU X ; Leave the address in X.
+ (fig-forth-auto680):03095 * RTS
+ (fig-forth-auto680):03096 * Version 2:
+ (fig-forth-auto680):03097 * LEAX CURENT,PCR
+ (fig-forth-auto680):03098 * JSR [,X]
+ (fig-forth-auto680):03099 * PULU X
+ (fig-forth-auto680):03100 * LDX [,X]
+ (fig-forth-auto680):03101 * PSHU X
+ (fig-forth-auto680):03102 * RTS
+ (fig-forth-auto680):03103 * Too greedy, too many smantic holes to fall through.
+ (fig-forth-auto680):03104 * If the address at the CFA is made relative,
+ (fig-forth-auto680):03105 * this is part of the code that would be affected
+ (fig-forth-auto680):03106 * if it is in native CPU code.
+ (fig-forth-auto680):03107 *
+ (fig-forth-auto680):03108 * ======>> 100 <<
+ (fig-forth-auto680):03109 * Wanted to do these as INCREMENTERs,
+ (fig-forth-auto680):03110 * but I need to stick with the model as much as possible,
+ (fig-forth-auto680):03111 * (mostly, LOL) adding code only to make the model more clear.
+ (fig-forth-auto680):03112 * ( pfa --- lfa )
+ (fig-forth-auto680):03113 * Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
+1AD7 83 (fig-forth-auto680):03114 FCB $83
+1AD8 4C46 (fig-forth-auto680):03115 FCC 'LF' ; 'LFA'
+1ADA C1 (fig-forth-auto680):03116 FCB $C1
+1ADB 1AC4 (fig-forth-auto680):03117 FDB LATEST-9
+1ADD 17B613A7 (fig-forth-auto680):03118 LFA FDB DOCOL,LIT8
+ (fig-forth-auto680):03119 * FCB 4
+1AE1 04 (fig-forth-auto680):03120 FCB 2*NATWID
+1AE2 1A01 (fig-forth-auto680):03121 FDB SUB
+1AE4 1662 (fig-forth-auto680):03122 FDB SEMIS
+ (fig-forth-auto680):03123 *
+ (fig-forth-auto680):03124 * ======>> 101 <<
+ (fig-forth-auto680):03125 * ( pfa --- cfa )
+ (fig-forth-auto680):03126 * Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
+1AE6 83 (fig-forth-auto680):03127 FCB $83
+1AE7 4346 (fig-forth-auto680):03128 FCC 'CF' ; 'CFA'
+1AE9 C1 (fig-forth-auto680):03129 FCB $C1
+1AEA 1AD7 (fig-forth-auto680):03130 FDB LFA-6
+ (fig-forth-auto680):03131 * CFA FDB DOCOL,TWO,SUB
+1AEC 17B617F41A01 (fig-forth-auto680):03132 CFA FDB DOCOL,NATWC,SUB
+1AF2 1662 (fig-forth-auto680):03133 FDB SEMIS
+ (fig-forth-auto680):03134 *
+ (fig-forth-auto680):03135 * ======>> 102 <<
+ (fig-forth-auto680):03136 * ( pfa --- nfa )
+ (fig-forth-auto680):03137 * Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
+1AF4 83 (fig-forth-auto680):03138 FCB $83
+1AF5 4E46 (fig-forth-auto680):03139 FCC 'NF' ; 'NFA'
+1AF7 C1 (fig-forth-auto680):03140 FCB $C1
+1AF8 1AE6 (fig-forth-auto680):03141 FDB CFA-6
+1AFA 17B613A7 (fig-forth-auto680):03142 NFA FDB DOCOL,LIT8
+ (fig-forth-auto680):03143 * FCB 5
+1AFE 05 (fig-forth-auto680):03144 FCB NATWID*2+1
+1AFF 1A01184216EA1AB1 (fig-forth-auto680):03145 FDB SUB,ONE,MINUS,TRAV
+1B07 1662 (fig-forth-auto680):03146 FDB SEMIS
+ (fig-forth-auto680):03147 *
+ (fig-forth-auto680):03148 * ======>> 103 <<
+ (fig-forth-auto680):03149 * ( nfa --- pfa )
+ (fig-forth-auto680):03150 * Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
+1B09 83 (fig-forth-auto680):03151 FCB $83
+1B0A 5046 (fig-forth-auto680):03152 FCC 'PF' ; 'PFA'
+1B0C C1 (fig-forth-auto680):03153 FCB $C1
+1B0D 1AF4 (fig-forth-auto680):03154 FDB NFA-6
+1B0F 17B618421AB113A7 (fig-forth-auto680):03155 PFA FDB DOCOL,ONE,TRAV,LIT8
+ (fig-forth-auto680):03156 * FCB 5
+1B17 05 (fig-forth-auto680):03157 FCB NATWID*2+1
+1B18 16C1 (fig-forth-auto680):03158 FDB PLUS
+1B1A 1662 (fig-forth-auto680):03159 FDB SEMIS
+ (fig-forth-auto680):03160 *
+ (fig-forth-auto680):03161 * ######>> screen 40 <<
+ (fig-forth-auto680):03162 * ======>> 104 <<
+ (fig-forth-auto680):03163 * ( --- )
+ (fig-forth-auto680):03164 * Save the parameter stack pointer in CSP for compiler checks.
+1B1C 84 (fig-forth-auto680):03165 FCB $84
+1B1D 214353 (fig-forth-auto680):03166 FCC '!CS' ; '!CSP'
+1B20 D0 (fig-forth-auto680):03167 FCB $D0
+1B21 1B09 (fig-forth-auto680):03168 FDB PFA-6
+1B23 17B6163B197E1787 (fig-forth-auto680):03169 SCSP FDB DOCOL,SPAT,CSP,STORE
+1B2B 1662 (fig-forth-auto680):03170 FDB SEMIS
+ (fig-forth-auto680):03171 *
+ (fig-forth-auto680):03172 * ======>> 105 <<
+ (fig-forth-auto680):03173 * ( 0 n --- ) ( *** )
+ (fig-forth-auto680):03174 * ( true n --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03175 * If flag is false, do nothing.
+ (fig-forth-auto680):03176 * If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
+ (fig-forth-auto680):03177 * Leaves cursor position (IN)
+ (fig-forth-auto680):03178 * and currently loading block number (BLK) on stack, for analysis.
+ (fig-forth-auto680):03179 *
+ (fig-forth-auto680):03180 * This one is too important to be high-level Forth codes.
+ (fig-forth-auto680):03181 * When we have an error, we want to disturb as little as possible.
+ (fig-forth-auto680):03182 * But fixing that cascades through ERROR and MESSAGE
+ (fig-forth-auto680):03183 * into the disk block system.
+ (fig-forth-auto680):03184 * And we aren't ready for that yet.
+1B2D 86 (fig-forth-auto680):03185 FCB $86
+1B2E 3F4552524F (fig-forth-auto680):03186 FCC '?ERRO' ; '?ERROR'
+1B33 D2 (fig-forth-auto680):03187 FCB $D2
+1B34 1B1C (fig-forth-auto680):03188 FDB SCSP-7
+ (fig-forth-auto680):03189 * QERR FDB *+NATWID
+ (fig-forth-auto680):03190 * LDD NATWID,U
+ (fig-forth-auto680):03191 * BNE QERROR
+ (fig-forth-auto680):03192 * LEAU 2*NATWID,U
+ (fig-forth-auto680):03193 * RTS
+ (fig-forth-auto680):03194 ** this doesn't work anyway: QERROR LBR ERROR
+1B36 17B617331409 (fig-forth-auto680):03195 QERR FDB DOCOL,SWAP,ZBRAN
+1B3C 0006 (fig-forth-auto680):03196 FDB QERR2-*-NATWID
+1B3E 1FE613FA (fig-forth-auto680):03197 FDB ERROR,BRAN
+1B42 0002 (fig-forth-auto680):03198 FDB QERR3-*-NATWID
+1B44 1725 (fig-forth-auto680):03199 QERR2 FDB DROP
+1B46 1662 (fig-forth-auto680):03200 QERR3 FDB SEMIS
+ (fig-forth-auto680):03201 *
+ (fig-forth-auto680):03202 * ======>> 106 <<
+ (fig-forth-auto680):03203 * STATE is compiling:
+ (fig-forth-auto680):03204 * ( --- ) ( *** )
+ (fig-forth-auto680):03205 * STATE is compiling:
+ (fig-forth-auto680):03206 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03207 * ERROR if not compiling.
+1B48 85 (fig-forth-auto680):03208 FCB $85
+1B49 3F434F4D (fig-forth-auto680):03209 FCC '?COM' ; '?COMP'
+1B4D D0 (fig-forth-auto680):03210 FCB $D0
+1B4E 1B2D (fig-forth-auto680):03211 FDB QERR-9
+1B50 17B61955176F169E (fig-forth-auto680):03212 QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8
+ 13A7
+1B5A 11 (fig-forth-auto680):03213 FCB $11
+1B5B 1B36 (fig-forth-auto680):03214 FDB QERR
+1B5D 1662 (fig-forth-auto680):03215 FDB SEMIS
+ (fig-forth-auto680):03216 *
+ (fig-forth-auto680):03217 * ======>> 107 <<
+ (fig-forth-auto680):03218 * STATE is executing:
+ (fig-forth-auto680):03219 * ( --- ) ( *** )
+ (fig-forth-auto680):03220 * STATE is executing:
+ (fig-forth-auto680):03221 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03222 * ERROR if not executing.
+1B5F 85 (fig-forth-auto680):03223 FCB $85
+1B60 3F455845 (fig-forth-auto680):03224 FCC '?EXE' ; '?EXEC'
+1B64 C3 (fig-forth-auto680):03225 FCB $C3
+1B65 1B48 (fig-forth-auto680):03226 FDB QCOMP-8
+1B67 17B61955176F13A7 (fig-forth-auto680):03227 QEXEC FDB DOCOL,STATE,AT,LIT8
+1B6F 12 (fig-forth-auto680):03228 FCB $12
+1B70 1B36 (fig-forth-auto680):03229 FDB QERR
+1B72 1662 (fig-forth-auto680):03230 FDB SEMIS
+ (fig-forth-auto680):03231 *
+ (fig-forth-auto680):03232 * ======>> 108 <<
+ (fig-forth-auto680):03233 * ( n1 n1 --- ) ( *** )
+ (fig-forth-auto680):03234 * ( n1 n2 --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03235 * ERROR if top two are unequal.
+ (fig-forth-auto680):03236 * MESSAGE says compiled conditionals do not match.
+1B74 86 (fig-forth-auto680):03237 FCB $86
+1B75 3F50414952 (fig-forth-auto680):03238 FCC '?PAIR' ; '?PAIRS'
+1B7A D3 (fig-forth-auto680):03239 FCB $D3
+1B7B 1B5F (fig-forth-auto680):03240 FDB QEXEC-8
+1B7D 17B61A0113A7 (fig-forth-auto680):03241 QPAIRS FDB DOCOL,SUB,LIT8
+1B83 13 (fig-forth-auto680):03242 FCB $13
+1B84 1B36 (fig-forth-auto680):03243 FDB QERR
+1B86 1662 (fig-forth-auto680):03244 FDB SEMIS
+ (fig-forth-auto680):03245 *
+ (fig-forth-auto680):03246 * ======>> 109 <<
+ (fig-forth-auto680):03247 * CSP and parameter stack are balanced (equal):
+ (fig-forth-auto680):03248 * ( --- ) ( *** )
+ (fig-forth-auto680):03249 * CSP and parameter stack are not balanced (unequal):
+ (fig-forth-auto680):03250 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03251 * ERROR if return/control stack is not at same level as last !CSP.
+ (fig-forth-auto680):03252 * Usually indicates that a definition has been left incomplete.
+1B88 84 (fig-forth-auto680):03253 FCB $84
+1B89 3F4353 (fig-forth-auto680):03254 FCC '?CS' ; '?CSP'
+1B8C D0 (fig-forth-auto680):03255 FCB $D0
+1B8D 1B74 (fig-forth-auto680):03256 FDB QPAIRS-9
+1B8F 17B6163B197E176F (fig-forth-auto680):03257 QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8
+ 1A0113A7
+1B9B 14 (fig-forth-auto680):03258 FCB $14
+1B9C 1B36 (fig-forth-auto680):03259 FDB QERR
+1B9E 1662 (fig-forth-auto680):03260 FDB SEMIS
+ (fig-forth-auto680):03261 *
+ (fig-forth-auto680):03262 * ======>> 110 <<
+ (fig-forth-auto680):03263 * Active BLK input:
+ (fig-forth-auto680):03264 * ( --- ) ( *** )
+ (fig-forth-auto680):03265 * No active BLK input:
+ (fig-forth-auto680):03266 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03267 * ERROR if not loading, i. e., if BLK is zero.
+1BA0 88 (fig-forth-auto680):03268 FCB $88
+1BA1 3F4C4F4144494E (fig-forth-auto680):03269 FCC '?LOADIN' ; '?LOADING'
+1BA8 C7 (fig-forth-auto680):03270 FCB $C7
+1BA9 1B88 (fig-forth-auto680):03271 FDB QCSP-7
+1BAB 17B61903176F169E (fig-forth-auto680):03272 QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8
+ 13A7
+1BB5 16 (fig-forth-auto680):03273 FCB $16
+1BB6 1B36 (fig-forth-auto680):03274 FDB QERR
+1BB8 1662 (fig-forth-auto680):03275 FDB SEMIS
+ (fig-forth-auto680):03276 *
+ (fig-forth-auto680):03277 * ######>> screen 41 <<
+ (fig-forth-auto680):03278 * ======>> 111 <<
+ (fig-forth-auto680):03279 * ( --- )
+ (fig-forth-auto680):03280 * Compile an in-line literal value from the instruction stream.
+1BBA 87 (fig-forth-auto680):03281 FCB $87
+1BBB 434F4D50494C (fig-forth-auto680):03282 FCC 'COMPIL' ; 'COMPILE'
+1BC1 C5 (fig-forth-auto680):03283 FCB $C5
+1BC2 1BA0 (fig-forth-auto680):03284 FDB QLOAD-11
+ (fig-forth-auto680):03285 * COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
+ (fig-forth-auto680):03286 * COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
+1BC4 17B61B50168B1742 (fig-forth-auto680):03287 COMPIL FDB DOCOL,QCOMP,FROMR,DUP,TOR,AT,COMMA
+ 167C176F19E0
+1BD2 1662 (fig-forth-auto680):03288 FDB SEMIS
+ (fig-forth-auto680):03289 *
+ (fig-forth-auto680):03290 * ======>> 112 <<
+ (fig-forth-auto680):03291 * ( --- ) P
+ (fig-forth-auto680):03292 * Clear the compile state bit(s) (shift to interpret).
+1BD4 C1 (fig-forth-auto680):03293 FCB $C1 [ immediate
+1BD5 DB (fig-forth-auto680):03294 FCB $DB
+1BD6 1BBA (fig-forth-auto680):03295 FDB COMPIL-10
+1BD8 17B6183A19551787 (fig-forth-auto680):03296 LBRAK FDB DOCOL,ZERO,STATE,STORE
+1BE0 1662 (fig-forth-auto680):03297 FDB SEMIS
+ (fig-forth-auto680):03298 *
+ (fig-forth-auto680):03299 * ======>> 113 <<
+ (fig-forth-auto680):03300 *
+ 00C0 (fig-forth-auto680):03301 STCOMP EQU $C0
+ (fig-forth-auto680):03302 * ( --- )
+ (fig-forth-auto680):03303 * Set the compile state bit(s) (shift to compile).
+1BE2 81 (fig-forth-auto680):03304 FCB $81 ]
+1BE3 DD (fig-forth-auto680):03305 FCB $DD
+1BE4 1BD4 (fig-forth-auto680):03306 FDB LBRAK-4
+1BE6 17B613A7 (fig-forth-auto680):03307 RBRAK FDB DOCOL,LIT8
+1BEA C0 (fig-forth-auto680):03308 FCB STCOMP
+1BEB 19551787 (fig-forth-auto680):03309 FDB STATE,STORE
+1BEF 1662 (fig-forth-auto680):03310 FDB SEMIS
+ (fig-forth-auto680):03311 *
+ (fig-forth-auto680):03312 * ======>> 114 <<
+ (fig-forth-auto680):03313 * ( --- )
+ (fig-forth-auto680):03314 * Toggle SMUDGE bit of LATEST definition header,
+ (fig-forth-auto680):03315 * to hide it until defined or reveal it after definition.
+1BF1 86 (fig-forth-auto680):03316 FCB $86
+1BF2 534D554447 (fig-forth-auto680):03317 FCC 'SMUDG' ; 'SMUDGE'
+1BF7 C5 (fig-forth-auto680):03318 FCB $C5
+1BF8 1BE2 (fig-forth-auto680):03319 FDB RBRAK-4
+1BFA 17B61ACD13A7 (fig-forth-auto680):03320 SMUDGE FDB DOCOL,LATEST,LIT8
+1C00 20 (fig-forth-auto680):03321 FCB FSMUDG
+1C01 1762 (fig-forth-auto680):03322 FDB TOGGLE
+1C03 1662 (fig-forth-auto680):03323 FDB SEMIS
+ (fig-forth-auto680):03324 *
+ (fig-forth-auto680):03325 * ======>> 115 <<
+ (fig-forth-auto680):03326 * ( --- )
+ (fig-forth-auto680):03327 * Set the conversion base to sixteen (b00010000).
+1C05 83 (fig-forth-auto680):03328 FCB $83
+1C06 4845 (fig-forth-auto680):03329 FCC 'HE' ; 'HEX'
+1C08 D8 (fig-forth-auto680):03330 FCB $D8
+1C09 1BF1 (fig-forth-auto680):03331 FDB SMUDGE-9
+1C0B 17B6 (fig-forth-auto680):03332 HEX FDB DOCOL
+1C0D 13A7 (fig-forth-auto680):03333 FDB LIT8
+1C0F 10 (fig-forth-auto680):03334 FCB 16 ; decimal sixteen
+1C10 19601787 (fig-forth-auto680):03335 FDB BASE,STORE
+1C14 1662 (fig-forth-auto680):03336 FDB SEMIS
+ (fig-forth-auto680):03337 *
+ (fig-forth-auto680):03338 * ======>> 116 <<
+ (fig-forth-auto680):03339 * ( --- )
+ (fig-forth-auto680):03340 * Set the conversion base to ten (b00001010).
+1C16 87 (fig-forth-auto680):03341 FCB $87
+1C17 444543494D41 (fig-forth-auto680):03342 FCC 'DECIMA' ; 'DECIMAL'
+1C1D CC (fig-forth-auto680):03343 FCB $CC
+1C1E 1C05 (fig-forth-auto680):03344 FDB HEX-6
+1C20 17B6 (fig-forth-auto680):03345 DEC FDB DOCOL
+1C22 13A7 (fig-forth-auto680):03346 FDB LIT8
+1C24 0A (fig-forth-auto680):03347 FCB 10 ; decimal ten
+1C25 19601787 (fig-forth-auto680):03348 FDB BASE,STORE
+1C29 1662 (fig-forth-auto680):03349 FDB SEMIS
+ (fig-forth-auto680):03350 *
+ (fig-forth-auto680):03351 * ######>> screen 42 <<
+ (fig-forth-auto680):03352 * ======>> 117 <<
+ (fig-forth-auto680):03353 * ( --- ) ( IP *** )
+ (fig-forth-auto680):03354 * Pop the saved IP and use it to
+ (fig-forth-auto680):03355 * compile the latest symbol as a reference to a ;CODE definition;
+ (fig-forth-auto680):03356 * overwrite the code field of the symbol found by LATEST
+ (fig-forth-auto680):03357 * with the address of the low-level characteristic code
+ (fig-forth-auto680):03358 * provided in the defining definition.
+ (fig-forth-auto680):03359 * Look closely at where things return, consider the operation of R> and >R .
+ (fig-forth-auto680):03360 *
+ (fig-forth-auto680):03361 * The machine-level code which follows (;CODE) in the instruction stream
+ (fig-forth-auto680):03362 * is not executed by the defining symbol,
+ (fig-forth-auto680):03363 * but becomes the characteristic of the defined symbol.
+ (fig-forth-auto680):03364 * This is the usual way to generate the characteristics of VARIABLEs,
+ (fig-forth-auto680):03365 * CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
+ (fig-forth-auto680):03366 *
+ (fig-forth-auto680):03367 * Finally, note that, if code shifts from low level back to high
+ (fig-forth-auto680):03368 * (native CPU machine code calling into a list of FORTH codes),
+ (fig-forth-auto680):03369 * the low level code can't just call a high-level definition.
+ (fig-forth-auto680):03370 * Leaf definitions can directly call other leaf definitions,
+ (fig-forth-auto680):03371 * but not non-leafs.
+ (fig-forth-auto680):03372 * It will need an anonymous list, probably embedded in the low-level code,
+ (fig-forth-auto680):03373 * and Y and X will have to be set appropriately before entering the list.
+1C2B 87 (fig-forth-auto680):03374 FCB $87
+1C2C 283B434F4445 (fig-forth-auto680):03375 FCC '(;CODE' ; '(;CODE)'
+1C32 A9 (fig-forth-auto680):03376 FCB $A9
+1C33 1C16 (fig-forth-auto680):03377 FDB DEC-10
+ (fig-forth-auto680):03378 * PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
+1C35 17B6168B (fig-forth-auto680):03379 PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+1C39 1ACD1B0F1AEC1787 (fig-forth-auto680):03380 FDB LATEST,PFA,CFA,STORE
+1C41 1662 (fig-forth-auto680):03381 FDB SEMIS
+ (fig-forth-auto680):03382 *
+ (fig-forth-auto680):03383 * ======>> 118 <<
+ (fig-forth-auto680):03384 * ( --- ) P
+ (fig-forth-auto680):03385 * ?CSP to see if there are loose ends in the defining definition
+ (fig-forth-auto680):03386 * before shifting to the assembler,
+ (fig-forth-auto680):03387 * compile (;CODE) in the defining definition's instruction stream,
+ (fig-forth-auto680):03388 * shift to interpreting,
+ (fig-forth-auto680):03389 * make the ASSEMBLER vocabulary current,
+ (fig-forth-auto680):03390 * and !CSP to mark the stack
+ (fig-forth-auto680):03391 * in preparation for assembling low-level code.
+ (fig-forth-auto680):03392 * Note that ;CODE, unlike DOES>, is IMMEDIATE,
+ (fig-forth-auto680):03393 * and compiles (;CODE),
+ (fig-forth-auto680):03394 * which will do the actual work of changing
+ (fig-forth-auto680):03395 * the LATEST definition's characteristic when the defining word runs.
+ (fig-forth-auto680):03396 * Assembly is done by the interpreter, rather than the compiler.
+ (fig-forth-auto680):03397 * I could have avoided the anomalous three-byte code fields by
+ (fig-forth-auto680):03398 *
+ (fig-forth-auto680):03399 * Note that the ASSEMBLER is not part of the model (at this time).
+ (fig-forth-auto680):03400 * That means that, until the assembler is ready,
+ (fig-forth-auto680):03401 * if you want to define low-level words,
+ (fig-forth-auto680):03402 * you have to poke (comma) in hand-assembled stuff.
+ (fig-forth-auto680):03403 *
+1C43 C5 (fig-forth-auto680):03404 FCB $C5 immediate
+1C44 3B434F44 (fig-forth-auto680):03405 FCC ';COD' ; ';CODE'
+1C48 C5 (fig-forth-auto680):03406 FCB $C5
+1C49 1C2B (fig-forth-auto680):03407 FDB PSCODE-10
+1C4B 17B61B8F1BC41C35 (fig-forth-auto680):03408 SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
+ 1BFA1BD81D56
+1C59 1662 (fig-forth-auto680):03409 FDB SEMIS
+ (fig-forth-auto680):03410 * note: "QSTACK" will be replaced by "ASSEMBLER" later
+ (fig-forth-auto680):03411 *
+ (fig-forth-auto680):03412 * ######>> screen 43 <<
+ (fig-forth-auto680):03413 * ======>> 119 <<
+ (fig-forth-auto680):03414 * ( --- ) C
+ (fig-forth-auto680):03415 * Make the word currently being defined
+ (fig-forth-auto680):03416 * build a header for DOES> definitions.
+ (fig-forth-auto680):03417 * Actually just compiles a CONSTANT zero
+ (fig-forth-auto680):03418 * which can be overwritten later by DOES>.
+ (fig-forth-auto680):03419 * Since the fig models were established, this technique has been deprecated.
+ (fig-forth-auto680):03420 *
+ (fig-forth-auto680):03421 * Note that <BUILDS is not IMMEDIATE,
+ (fig-forth-auto680):03422 * and therefore executes during a definition's run-time,
+ (fig-forth-auto680):03423 * rather than its compile-time.
+ (fig-forth-auto680):03424 * It is not intended to be used directly,
+ (fig-forth-auto680):03425 * but rather so that one definition word can build another.
+ (fig-forth-auto680):03426 * Also, note that nothing particularly special happens
+ (fig-forth-auto680):03427 * in the defining definition until DOES> executes.
+ (fig-forth-auto680):03428 * The name <BUILDS is intended to be a reminder of what is about to occur.
+ (fig-forth-auto680):03429 *
+ (fig-forth-auto680):03430 * <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
+1C5B 87 (fig-forth-auto680):03431 FCB $87
+1C5C 3C4255494C44 (fig-forth-auto680):03432 FCC '<BUILD' ; '<BUILDS'
+1C62 D3 (fig-forth-auto680):03433 FCB $D3
+1C63 1C43 (fig-forth-auto680):03434 FDB SEMIC-8
+1C65 17B6183A17DC (fig-forth-auto680):03435 BUILDS FDB DOCOL,ZERO,CON
+1C6B 1662 (fig-forth-auto680):03436 FDB SEMIS
+ (fig-forth-auto680):03437 *
+ (fig-forth-auto680):03438 * ======>> 120 <<
+ (fig-forth-auto680):03439 * ( --- ) ( IP *** ) C
+ (fig-forth-auto680):03440 * Define run-time behavior of definitions compiled/defined
+ (fig-forth-auto680):03441 * by a high-level defining definition --
+ (fig-forth-auto680):03442 * the FORTH equivalent of a compiler-compiler.
+ (fig-forth-auto680):03443 * DOES> assumes that the LATEST symbol table entry
+ (fig-forth-auto680):03444 * has at least one word of parameter field,
+ (fig-forth-auto680):03445 * which <BUILDS provides.
+ (fig-forth-auto680):03446 * Note that DOES> is also not IMMEDIATE.
+ (fig-forth-auto680):03447 *
+ (fig-forth-auto680):03448 * When the defining word containing DOES> executes the DOES> icode,
+ (fig-forth-auto680):03449 * it overwrites the LATEST symbol's CFA with jsr <XDOES,
+ (fig-forth-auto680):03450 * overwrites the first word of that symbol's parameter field with its own IP,
+ (fig-forth-auto680):03451 * and pops the previous IP from the return stack.
+ (fig-forth-auto680):03452 * The icodes which follow DOES> in the stream
+ (fig-forth-auto680):03453 * do not execute at the defining word's run-time.
+ (fig-forth-auto680):03454 *
+ (fig-forth-auto680):03455 * Examining XDOES in the virtual machine shows
+ (fig-forth-auto680):03456 * that the defined word will execute those icodes
+ (fig-forth-auto680):03457 * which follow DOES> at its own run-time.
+ (fig-forth-auto680):03458 *
+ (fig-forth-auto680):03459 * The advantage of this kind of behaviour,
+ (fig-forth-auto680):03460 * which you will also note in ;CODE,
+ (fig-forth-auto680):03461 * is that the defined word can contain
+ (fig-forth-auto680):03462 * both operations and data to be operated on.
+ (fig-forth-auto680):03463 * This is how FORTH data objects define their own behavior.
+ (fig-forth-auto680):03464 *
+ (fig-forth-auto680):03465 * Finally, note that the effective parameter field for DOES> definitions
+ (fig-forth-auto680):03466 * starts two NATWID words after the CFA, instead of just one
+ (fig-forth-auto680):03467 * (four bytes instead of two in a sixteen-bit addressing Forth).
+ (fig-forth-auto680):03468 *
+ (fig-forth-auto680):03469 * VOCABULARYs will use this. See definition of word FORTH.
+1C6D 85 (fig-forth-auto680):03470 FCB $85
+1C6E 444F4553 (fig-forth-auto680):03471 FCC 'DOES' ; 'DOES>'
+1C72 BE (fig-forth-auto680):03472 FCB $BE
+1C73 1C5B (fig-forth-auto680):03473 FDB BUILDS-10
+ (fig-forth-auto680):03474 * DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
+1C75 17B6168B (fig-forth-auto680):03475 DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+1C79 1ACD1B0F1787 (fig-forth-auto680):03476 FDB LATEST,PFA,STORE
+1C7F 1C35 (fig-forth-auto680):03477 FDB PSCODE
+ (fig-forth-auto680):03478 *
+ (fig-forth-auto680):03479 * ( --- PFA+NATWID ) ( *** IP )
+ (fig-forth-auto680):03480 * Characteristic of a DOES> defined word.
+ (fig-forth-auto680):03481 * The characteristics of DOES> definitions are written in high-level
+ (fig-forth-auto680):03482 * Forth codes rather than native CPU machine level code.
+ (fig-forth-auto680):03483 * The first parameter word points to the high-level characteristic.
+ (fig-forth-auto680):03484 * This routine's job is to push the IP,
+ (fig-forth-auto680):03485 * load the high level characteristic pointer in IP,
+ (fig-forth-auto680):03486 * and leave the address following the characteristic pointer on the stack
+ (fig-forth-auto680):03487 * so the parameter field can be accessed.
+1C81 ECE4 (fig-forth-auto680):03488 DODOES LDD ,S ; Keep the return address.
+1C83 10AFE4 (fig-forth-auto680):03489 STY ,S ; Save/nest the current IP on the return stack.
+1C86 10AE02 (fig-forth-auto680):03490 LDY NATWID,X ; First parameter is new IP.
+1C89 3004 (fig-forth-auto680):03491 LEAX 2*NATWID,X ; Address of second parameter.
+1C8B 3610 (fig-forth-auto680):03492 PSHU X
+1C8D 1F05 (fig-forth-auto680):03493 TFR D,PC ; Synthetic return.
+ (fig-forth-auto680):03494 *
+ (fig-forth-auto680):03495 * From the 6800 model:
+ (fig-forth-auto680):03496 * DODOES LDA IP
+ (fig-forth-auto680):03497 * LDB IP+1
+ (fig-forth-auto680):03498 * LDX RP make room on return stack
+ (fig-forth-auto680):03499 * LEAX -1,X ;
+ (fig-forth-auto680):03500 * LEAX -1,X ;
+ (fig-forth-auto680):03501 * STX RP
+ (fig-forth-auto680):03502 * STA 2,X push return address
+ (fig-forth-auto680):03503 * STB 3,X
+ (fig-forth-auto680):03504 * LDX W get addr of pointer to run-time code
+ (fig-forth-auto680):03505 * LEAX 1,X ;
+ (fig-forth-auto680):03506 * LEAX 1,X ;
+ (fig-forth-auto680):03507 * STX N stash it in scratch area
+ (fig-forth-auto680):03508 * LDX 0,X get new IP
+ (fig-forth-auto680):03509 * STX IP
+ (fig-forth-auto680):03510 * CLRA ; get address of parameter
+ (fig-forth-auto680):03511 * LDB #2
+ (fig-forth-auto680):03512 * ADDB N+1
+ (fig-forth-auto680):03513 * ADCA N
+ (fig-forth-auto680):03514 * PSHS B ; and push it on data stack
+ (fig-forth-auto680):03515 * PSHS A ;
+ (fig-forth-auto680):03516 * JMP NEXT2
+ (fig-forth-auto680):03517 *
+ (fig-forth-auto680):03518 * ######>> screen 44 <<
+ (fig-forth-auto680):03519 * ======>> 121 <<
+ (fig-forth-auto680):03520 * ( strptr --- strptr+1 count )
+ (fig-forth-auto680):03521 * Convert counted string to string and count.
+ (fig-forth-auto680):03522 * (Fetch the byte at strptr, post-increment.)
+1C8F 85 (fig-forth-auto680):03523 FCB $85
+1C90 434F554E (fig-forth-auto680):03524 FCC 'COUN' ; 'COUNT'
+1C94 D4 (fig-forth-auto680):03525 FCB $D4
+1C95 1C6D (fig-forth-auto680):03526 FDB DOES-8
+1C97 17B6174219A81733 (fig-forth-auto680):03527 COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
+ 177B
+1CA1 1662 (fig-forth-auto680):03528 FDB SEMIS
+ (fig-forth-auto680):03529 *
+ (fig-forth-auto680):03530 * ======>> 122 <<
+ (fig-forth-auto680):03531 * ( strptr count --- )
+ (fig-forth-auto680):03532 * EMIT count characters at strptr.
+1CA3 84 (fig-forth-auto680):03533 FCB $84
+1CA4 545950 (fig-forth-auto680):03534 FCC 'TYP' ; 'TYPE'
+1CA7 C5 (fig-forth-auto680):03535 FCB $C5
+1CA8 1C8F (fig-forth-auto680):03536 FDB COUNT-8
+1CAA 17B61A871409 (fig-forth-auto680):03537 TYPE FDB DOCOL,DDUP,ZBRAN
+1CB0 0016 (fig-forth-auto680):03538 FDB TYPE3-*-NATWID
+1CB2 171716C117331453 (fig-forth-auto680):03539 FDB OVER,PLUS,SWAP,XDO
+1CBA 1465177B1541141D (fig-forth-auto680):03540 TYPE2 FDB I,CAT,EMIT,XLOOP
+1CC2 FFF6 (fig-forth-auto680):03541 FDB TYPE2-*-NATWID
+1CC4 13FA (fig-forth-auto680):03542 FDB BRAN
+1CC6 0002 (fig-forth-auto680):03543 FDB TYPE4-*-NATWID
+1CC8 1725 (fig-forth-auto680):03544 TYPE3 FDB DROP
+1CCA 1662 (fig-forth-auto680):03545 TYPE4 FDB SEMIS
+ (fig-forth-auto680):03546 *
+ (fig-forth-auto680):03547 * ======>> 123 <<
+ (fig-forth-auto680):03548 * ( strptr count1 --- strptr count2 )
+ (fig-forth-auto680):03549 * Supress trailing blanks (subtract count of trailing blanks from strptr).
+1CCC 89 (fig-forth-auto680):03550 FCB $89
+1CCD 2D545241494C494E (fig-forth-auto680):03551 FCC '-TRAILIN' ; '-TRAILING'
+1CD5 C7 (fig-forth-auto680):03552 FCB $C7
+1CD6 1CA3 (fig-forth-auto680):03553 FDB TYPE-7
+1CD8 17B61742183A1453 (fig-forth-auto680):03554 DTRAIL FDB DOCOL,DUP,ZERO,XDO
+1CE0 1717171716C11842 (fig-forth-auto680):03555 DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
+ 1A01177B185B
+1CEE 1A011409 (fig-forth-auto680):03556 FDB SUB,ZBRAN
+1CF2 0006 (fig-forth-auto680):03557 FDB DTRAL3-*-NATWID
+1CF4 167013FA (fig-forth-auto680):03558 FDB LEAVE,BRAN
+1CF8 0004 (fig-forth-auto680):03559 FDB DTRAL4-*-NATWID
+1CFA 18421A01 (fig-forth-auto680):03560 DTRAL3 FDB ONE,SUB
+1CFE 141D (fig-forth-auto680):03561 DTRAL4 FDB XLOOP
+1D00 FFDE (fig-forth-auto680):03562 FDB DTRAL2-*-NATWID
+1D02 1662 (fig-forth-auto680):03563 FDB SEMIS
+ (fig-forth-auto680):03564 *
+ (fig-forth-auto680):03565 * ======>> 124 <<
+ (fig-forth-auto680):03566 * ( --- )
+ (fig-forth-auto680):03567 * TYPE counted string out of instruction stream (updating IP).
+1D04 84 (fig-forth-auto680):03568 FCB $84
+1D05 282E22 (fig-forth-auto680):03569 FCC '(."' ; '(.")'
+1D08 A9 (fig-forth-auto680):03570 FCB $A9
+1D09 1CCC (fig-forth-auto680):03571 FDB DTRAIL-12
+ (fig-forth-auto680):03572 * PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
+ (fig-forth-auto680):03573 * PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
+1D0B 17B616971C971742 (fig-forth-auto680):03574 PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP
+ 19A8
+1D15 168B16C1167C1CAA (fig-forth-auto680):03575 FDB FROMR,PLUS,TOR,TYPE
+1D1D 1662 (fig-forth-auto680):03576 FDB SEMIS
+ (fig-forth-auto680):03577 *
+ (fig-forth-auto680):03578 * ======>> 125 <<
+ (fig-forth-auto680):03579 * ( --- ) P
+ (fig-forth-auto680):03580 * { ." something-to-be-printed " } typical input
+ (fig-forth-auto680):03581 * Use WORD to parse to trailing quote;
+ (fig-forth-auto680):03582 * if compiling, compile XDOTQ and string parsed,
+ (fig-forth-auto680):03583 * otherwise, TYPE string.
+1D1F C2 (fig-forth-auto680):03584 FCB $C2 immediate
+1D20 2E (fig-forth-auto680):03585 FCC '.' ; '."'
+1D21 A2 (fig-forth-auto680):03586 FCB $A2
+1D22 1D04 (fig-forth-auto680):03587 FDB PDOTQ-7
+1D24 17B6 (fig-forth-auto680):03588 DOTQ FDB DOCOL
+1D26 13A7 (fig-forth-auto680):03589 FDB LIT8
+1D28 22 (fig-forth-auto680):03590 FCB $22 ascii quote
+1D29 1955176F1409 (fig-forth-auto680):03591 FDB STATE,AT,ZBRAN
+1D2F 0012 (fig-forth-auto680):03592 FDB DOTQ1-*-NATWID
+1D31 1BC41D0B1EBB (fig-forth-auto680):03593 FDB COMPIL,PDOTQ,WORD
+1D37 19C4177B19A819D4 (fig-forth-auto680):03594 FDB HERE,CAT,ONEP,ALLOT,BRAN
+ 13FA
+1D41 0008 (fig-forth-auto680):03595 FDB DOTQ2-*-NATWID
+1D43 1EBB19C41C971CAA (fig-forth-auto680):03596 DOTQ1 FDB WORD,HERE,COUNT,TYPE
+1D4B 1662 (fig-forth-auto680):03597 DOTQ2 FDB SEMIS
+ (fig-forth-auto680):03598 *
+ (fig-forth-auto680):03599 * ######>> screen 45 <<
+ (fig-forth-auto680):03600 * ======>> 126 <<== MACHINE DEPENDENT
+ (fig-forth-auto680):03601 * ( --- ) ( *** )
+ (fig-forth-auto680):03602 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03603 * ERROR if parameter stack out of bounds.
+ (fig-forth-auto680):03604 *
+ (fig-forth-auto680):03605 * But checking whether the stack is in bounds or not
+ (fig-forth-auto680):03606 * really should not use the stack.
+ (fig-forth-auto680):03607 * And there really should be a ?RSTACK, as well.
+1D4D 86 (fig-forth-auto680):03608 FCB $86
+1D4E 3F53544143 (fig-forth-auto680):03609 FCC '?STAC' ; '?STACK'
+1D53 CB (fig-forth-auto680):03610 FCB $CB
+1D54 1D1F (fig-forth-auto680):03611 FDB DOTQ-5
+1D56 17B613A7 (fig-forth-auto680):03612 QSTACK FDB DOCOL,LIT8
+ (fig-forth-auto680):03613 * FCB $12
+1D5A 12 (fig-forth-auto680):03614 FCB SINIT-ORIG
+ (fig-forth-auto680):03615 * But why use that instead of XSPZER (S0)?
+ (fig-forth-auto680):03616 * Multi-user or multi-tasking would not want that.
+ (fig-forth-auto680):03617 * CMPU <XSPZER
+ (fig-forth-auto680):03618 * FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
+1D5B 1899176F163B1A1A (fig-forth-auto680):03619 FDB PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
+ 1842
+1D65 1B36 (fig-forth-auto680):03620 FDB QERR
+ (fig-forth-auto680):03621 * prints 'empty stack'
+ (fig-forth-auto680):03622 *
+1D67 163B (fig-forth-auto680):03623 QSTAC2 FDB SPAT
+ (fig-forth-auto680):03624 * Here, we compare with a value at least 128
+ (fig-forth-auto680):03625 * higher than dict. ptr. (DICTPT)
+1D69 19C413A7 (fig-forth-auto680):03626 FDB HERE,LIT8
+1D6D 80 (fig-forth-auto680):03627 FCB $80 ; This is a rough check anyway, leave it as is.
+1D6E 16C11A1A1409 (fig-forth-auto680):03628 FDB PLUS,LESS,ZBRAN
+1D74 0004 (fig-forth-auto680):03629 FDB QSTAC3-*-NATWID
+1D76 184A (fig-forth-auto680):03630 FDB TWO ; NOT the NATWID constant!
+1D78 1B36 (fig-forth-auto680):03631 FDB QERR
+ (fig-forth-auto680):03632 * prints 'full stack'
+ (fig-forth-auto680):03633 *
+1D7A 1662 (fig-forth-auto680):03634 QSTAC3 FDB SEMIS
+ (fig-forth-auto680):03635 *
+ (fig-forth-auto680):03636 * ======>> 127 << this word's function
+ (fig-forth-auto680):03637 * is done by ?STACK in this version
+ (fig-forth-auto680):03638 * FCB $85
+ (fig-forth-auto680):03639 * FCC 4,?FREE
+ (fig-forth-auto680):03640 * FCB $C5
+ (fig-forth-auto680):03641 * FDB QSTACK-9
+ (fig-forth-auto680):03642 *QFREE FDB DOCOL,SPAT,HERE,LIT8
+ (fig-forth-auto680):03643 * FCB $80
+ (fig-forth-auto680):03644 * FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
+ (fig-forth-auto680):03645 *
+ (fig-forth-auto680):03646 * ######>> screen 46 <<
+ (fig-forth-auto680):03647 * ======>> 128 <<
+ (fig-forth-auto680):03648 * ( buffer n --- )
+ (fig-forth-auto680):03649 * ***** Check that this is how it works here:
+ (fig-forth-auto680):03650 * Get up to n-1 characters from the keyboard,
+ (fig-forth-auto680):03651 * storing at buffer and echoing, with backspace editing,
+ (fig-forth-auto680):03652 * quitting when a CR is read.
+ (fig-forth-auto680):03653 * Terminate it with a NUL.
+1D7C 86 (fig-forth-auto680):03654 FCB $86
+1D7D 4558504543 (fig-forth-auto680):03655 FCC 'EXPEC' ; 'EXPECT'
+1D82 D4 (fig-forth-auto680):03656 FCB $D4
+1D83 1D4D (fig-forth-auto680):03657 FDB QSTACK-9
+1D85 17B6171716C11717 (fig-forth-auto680):03658 EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
+ 1453
+ (fig-forth-auto680):03659 * EXPEC2 FDB KEY,DUP,LIT8
+1D8F 1555 (fig-forth-auto680):03660 EXPEC2 FDB KEY
+1D91 1399001C13B9 (fig-forth-auto680):03661 FDB LIT,$1C,SHOTOS ; DBG
+1D97 174213A7 (fig-forth-auto680):03662 FDB DUP,LIT8
+1D9B 0E (fig-forth-auto680):03663 FCB BACKSP-ORIG
+1D9C 1899176F1A0E1409 (fig-forth-auto680):03664 FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing
+1DA4 001D (fig-forth-auto680):03665 FDB EXPEC3-*-NATWID
+1DA6 172513A7 (fig-forth-auto680):03666 FDB DROP,LIT8
+1DAA 08 (fig-forth-auto680):03667 FCB 8 ( backspace character to emit )
+1DAB 171714651A0E1742 (fig-forth-auto680):03668 FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
+ 168B184A1A0116C1
+1DBB 167C1A0113FA (fig-forth-auto680):03669 FDB TOR,SUB,BRAN
+1DC1 0025 (fig-forth-auto680):03670 FDB EXPEC6-*-NATWID
+1DC3 174213A7 (fig-forth-auto680):03671 EXPEC3 FDB DUP,LIT8
+1DC7 0D (fig-forth-auto680):03672 FCB $D ( carriage return )
+1DC8 1A0E1409 (fig-forth-auto680):03673 FDB EQUAL,ZBRAN
+1DCC 000C (fig-forth-auto680):03674 FDB EXPEC4-*-NATWID
+1DCE 16701725185B183A (fig-forth-auto680):03675 FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
+ 13FA
+1DD8 0002 (fig-forth-auto680):03676 FDB EXPEC5-*-NATWID
+1DDA 1742 (fig-forth-auto680):03677 EXPEC4 FDB DUP
+1DDC 14651795183A1465 (fig-forth-auto680):03678 EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
+ 19A81787
+1DE8 1541141D (fig-forth-auto680):03679 EXPEC6 FDB EMIT,XLOOP
+1DEC FFA1 (fig-forth-auto680):03680 FDB EXPEC2-*-NATWID
+1DEE 1725 (fig-forth-auto680):03681 FDB DROP
+1DF0 1662 (fig-forth-auto680):03682 FDB SEMIS
+ (fig-forth-auto680):03683 *
+ (fig-forth-auto680):03684 * ======>> 129 <<
+ (fig-forth-auto680):03685 * ( --- )
+ (fig-forth-auto680):03686 * EXPECT 128 (TWID) characters to TIB.
+1DF2 85 (fig-forth-auto680):03687 FCB $85
+1DF3 51554552 (fig-forth-auto680):03688 FCC 'QUER' ; 'QUERY'
+1DF7 D9 (fig-forth-auto680):03689 FCB $D9
+1DF8 1D7C (fig-forth-auto680):03690 FDB EXPECT-9
+1DFA 17B618BB176F199F (fig-forth-auto680):03691 QUERY FDB DOCOL,TIB,AT,COLUMS
+1E02 176F1D8513DC183A (fig-forth-auto680):03692 FDB AT,EXPECT,TRON,ZERO,IN,STORE,TROFF
+ 190C178713D0
+1E10 1662 (fig-forth-auto680):03693 FDB SEMIS
+ (fig-forth-auto680):03694 *
+ (fig-forth-auto680):03695 * ======>> 130 <<
+ (fig-forth-auto680):03696 * ( --- ) P
+ (fig-forth-auto680):03697 * End interpretation of a line or screen, and/or prepare for a new block.
+ (fig-forth-auto680):03698 * Note that the name of this definition is an empty string,
+ (fig-forth-auto680):03699 * so it matches on the terminating NUL in the terminal or block buffer.
+1E12 C1 (fig-forth-auto680):03700 FCB $C1 immediate < carriage return >
+1E13 80 (fig-forth-auto680):03701 FCB $80
+1E14 1DF2 (fig-forth-auto680):03702 FDB QUERY-8
+1E16 17B61903176F1409 (fig-forth-auto680):03703 NULL FDB DOCOL,BLK,AT,ZBRAN
+1E1E 0024 (fig-forth-auto680):03704 FDB NULL2-*-NATWID
+1E20 18421903174E (fig-forth-auto680):03705 FDB ONE,BLK,PSTORE
+1E26 183A190C17871903 (fig-forth-auto680):03706 FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
+ 176F188B2334
+1E34 169E (fig-forth-auto680):03707 FDB ZEQU
+ (fig-forth-auto680):03708 * check for end of screen
+1E36 1409 (fig-forth-auto680):03709 FDB ZBRAN
+1E38 0006 (fig-forth-auto680):03710 FDB NULL1-*-NATWID
+1E3A 1B67168B1725 (fig-forth-auto680):03711 FDB QEXEC,FROMR,DROP
+1E40 13FA (fig-forth-auto680):03712 NULL1 FDB BRAN
+1E42 0004 (fig-forth-auto680):03713 FDB NULL3-*-NATWID
+1E44 168B1725 (fig-forth-auto680):03714 NULL2 FDB FROMR,DROP
+1E48 1662 (fig-forth-auto680):03715 NULL3 FDB SEMIS
+ (fig-forth-auto680):03716 *
+ (fig-forth-auto680):03717 * ######>> screen 47 <<
+ (fig-forth-auto680):03718 * ======>> 133 <<
+ (fig-forth-auto680):03719 * ( adr n b --- )
+ (fig-forth-auto680):03720 * Fill n bytes at adr with b.
+1E4A 84 (fig-forth-auto680):03721 FCB $84
+1E4B 46494C (fig-forth-auto680):03722 FCC 'FIL' ; 'FILL'
+1E4E CC (fig-forth-auto680):03723 FCB $CC
+1E4F 1E12 (fig-forth-auto680):03724 FDB NULL-4
+1E51 17B61733167C1717 (fig-forth-auto680):03725 FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
+ 1795174219A8
+1E5F 168B18421A011583 (fig-forth-auto680):03726 FDB FROMR,ONE,SUB,CMOVE
+1E67 1662 (fig-forth-auto680):03727 FDB SEMIS
+ (fig-forth-auto680):03728 *
+ (fig-forth-auto680):03729 * ======>> 134 <<
+ (fig-forth-auto680):03730 * ( adr n --- )
+ (fig-forth-auto680):03731 * Fill n bytes with 0.
+1E69 85 (fig-forth-auto680):03732 FCB $85
+1E6A 45524153 (fig-forth-auto680):03733 FCC 'ERAS' ; 'ERASE'
+1E6E C5 (fig-forth-auto680):03734 FCB $C5
+1E6F 1E4A (fig-forth-auto680):03735 FDB FILL-7
+1E71 17B6183A1E51 (fig-forth-auto680):03736 ERASE FDB DOCOL,ZERO,FILL
+1E77 1662 (fig-forth-auto680):03737 FDB SEMIS
+ (fig-forth-auto680):03738 *
+ (fig-forth-auto680):03739 * ======>> 135 <<
+ (fig-forth-auto680):03740 * ( adr n --- )
+ (fig-forth-auto680):03741 * Fill n bytes with ASCII SPACE.
+1E79 86 (fig-forth-auto680):03742 FCB $86
+1E7A 424C414E4B (fig-forth-auto680):03743 FCC 'BLANK' ; 'BLANKS'
+1E7F D3 (fig-forth-auto680):03744 FCB $D3
+1E80 1E69 (fig-forth-auto680):03745 FDB ERASE-8
+1E82 17B6185B1E51 (fig-forth-auto680):03746 BLANKS FDB DOCOL,BL,FILL
+1E88 1662 (fig-forth-auto680):03747 FDB SEMIS
+ (fig-forth-auto680):03748 *
+ (fig-forth-auto680):03749 * ======>> 136 <<
+ (fig-forth-auto680):03750 * ( c --- )
+ (fig-forth-auto680):03751 * Format a character at the left of the HLD output buffer.
+1E8A 84 (fig-forth-auto680):03752 FCB $84
+1E8B 484F4C (fig-forth-auto680):03753 FCC 'HOL' ; 'HOLD'
+1E8E C4 (fig-forth-auto680):03754 FCB $C4
+1E8F 1E79 (fig-forth-auto680):03755 FDB BLANKS-9
+1E91 17B61399FFFF1991 (fig-forth-auto680):03756 HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
+ 174E1991176F1795
+1EA1 1662 (fig-forth-auto680):03757 FDB SEMIS
+ (fig-forth-auto680):03758 *
+ (fig-forth-auto680):03759 * ======>> 137 <<
+ (fig-forth-auto680):03760 * ( --- adr )
+ (fig-forth-auto680):03761 * Give the address of the output PAD buffer.
+ (fig-forth-auto680):03762 * PAD points to the end of a 68 byte buffer for numeric conversion.
+1EA3 83 (fig-forth-auto680):03763 FCB $83
+1EA4 5041 (fig-forth-auto680):03764 FCC 'PA' ; 'PAD'
+1EA6 C4 (fig-forth-auto680):03765 FCB $C4
+1EA7 1E8A (fig-forth-auto680):03766 FDB HOLD-7
+1EA9 17B619C413A7 (fig-forth-auto680):03767 PAD FDB DOCOL,HERE,LIT8
+1EAF 44 (fig-forth-auto680):03768 FCB $44
+1EB0 16C1 (fig-forth-auto680):03769 FDB PLUS
+1EB2 1662 (fig-forth-auto680):03770 FDB SEMIS
+ (fig-forth-auto680):03771 *
+ (fig-forth-auto680):03772 * ######>> screen 48 <<
+ (fig-forth-auto680):03773 * ======>> 138 <<
+ (fig-forth-auto680):03774 * ( c --- )
+ (fig-forth-auto680):03775 * Scan a string terminated by the character c or ASCII NUL out of input;
+ (fig-forth-auto680):03776 * store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
+ (fig-forth-auto680):03777 * Leading c are passed over, per ENCLOSE.
+ (fig-forth-auto680):03778 * Scans from BLK, or from TIB if BLK is zero.
+ (fig-forth-auto680):03779 * May overwrite the numeric conversion pad,
+ (fig-forth-auto680):03780 * if really long (length > 31) symbols are scanned.
+1EB4 84 (fig-forth-auto680):03781 FCB $84
+1EB5 574F52 (fig-forth-auto680):03782 FCC 'WOR' ; 'WORD'
+1EB8 C4 (fig-forth-auto680):03783 FCB $C4
+1EB9 1EA3 (fig-forth-auto680):03784 FDB PAD-6
+1EBB 17B61903176F1409 (fig-forth-auto680):03785 WORD FDB DOCOL,BLK,AT,ZBRAN
+1EC3 000A (fig-forth-auto680):03786 FDB WORD2-*-NATWID
+1EC5 1903176F249113FA (fig-forth-auto680):03787 FDB BLK,AT,BLOCK,BRAN
+1ECD 0004 (fig-forth-auto680):03788 FDB WORD3-*-NATWID
+1ECF 18BB176F (fig-forth-auto680):03789 WORD2 FDB TIB,AT
+1ED3 190C176F16C11733 (fig-forth-auto680):03790 WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
+ 14FD19C413A7
+1EE1 22 (fig-forth-auto680):03791 FCB 34
+1EE2 1E82190C174E1717 (fig-forth-auto680):03792 FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
+ 1A01167C169719C4
+1EF2 179516C119C419A8 (fig-forth-auto680):03793 FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
+ 168B1583
+1EFE 1662 (fig-forth-auto680):03794 FDB SEMIS
+ (fig-forth-auto680):03795 *
+ (fig-forth-auto680):03796 * ######>> screen 49 <<
+ (fig-forth-auto680):03797 * ======>> 139 <<
+ (fig-forth-auto680):03798 * ( d1 string --- d2 adr )
+ (fig-forth-auto680):03799 * Convert the text at string into a number, accumulating the result into d1,
+ (fig-forth-auto680):03800 * leaving adr pointing to the first character not converted.
+ (fig-forth-auto680):03801 * If DPL is non-negative at entry,
+ (fig-forth-auto680):03802 * accumulates the number of characters converted into DPL.
+1F00 88 (fig-forth-auto680):03803 FCB $88
+1F01 284E554D424552 (fig-forth-auto680):03804 FCC '(NUMBER' ; '(NUMBER)'
+1F08 A9 (fig-forth-auto680):03805 FCB $A9
+1F09 1EB4 (fig-forth-auto680):03806 FDB WORD-7
+1F0B 17B6 (fig-forth-auto680):03807 PNUMB FDB DOCOL
+1F0D 19A81742167C177B (fig-forth-auto680):03808 PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
+ 1960176F14741409
+1F1D 002A (fig-forth-auto680):03809 FDB PNUMB4-*-NATWID
+1F1F 17331960176F15A0 (fig-forth-auto680):03810 FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
+ 17251A401960
+1F2D 176F15A016CF196A (fig-forth-auto680):03811 FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
+ 176F19A81409
+1F3B 0006 (fig-forth-auto680):03812 FDB PNUMB3-*-NATWID
+1F3D 1842196A174E (fig-forth-auto680):03813 FDB ONE,DPL,PSTORE
+1F43 168B13FA (fig-forth-auto680):03814 PNUMB3 FDB FROMR,BRAN
+1F47 FFC4 (fig-forth-auto680):03815 FDB PNUMB2-*-NATWID
+1F49 168B (fig-forth-auto680):03816 PNUMB4 FDB FROMR
+1F4B 1662 (fig-forth-auto680):03817 FDB SEMIS
+ (fig-forth-auto680):03818 *
+ (fig-forth-auto680):03819 * ======>> 140 <<
+ (fig-forth-auto680):03820 * ( ctstr --- d )
+ (fig-forth-auto680):03821 * Convert text at ctstr to a double integer,
+ (fig-forth-auto680):03822 * taking the 0 ERROR if the conversion is not valid.
+ (fig-forth-auto680):03823 * If a decimal point is present,
+ (fig-forth-auto680):03824 * accumulate the count of digits to the decimal point's right into DPL
+ (fig-forth-auto680):03825 * (negative DPL at exit indicates single precision).
+ (fig-forth-auto680):03826 * ctstr is a counted string
+ (fig-forth-auto680):03827 * -- the first byte at ctstr is the length of the string,
+ (fig-forth-auto680):03828 * but NUMBER ignores the count and expects a NUL terminator instead.
+1F4D 86 (fig-forth-auto680):03829 FCB $86
+1F4E 4E554D4245 (fig-forth-auto680):03830 FCC 'NUMBE' ; 'NUMBER'
+1F53 D2 (fig-forth-auto680):03831 FCB $D2
+1F54 1F00 (fig-forth-auto680):03832 FDB PNUMB-11
+1F56 17B6183A183A1A40 (fig-forth-auto680):03833 NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
+ 174219A8177B13A7
+1F66 2D (fig-forth-auto680):03834 FCC "-" minus sign
+1F67 1A0E1742167C16C1 (fig-forth-auto680):03835 FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
+ 1399FFFF
+1F73 196A17871F0B1742 (fig-forth-auto680):03836 NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
+ 177B185B1A01
+1F81 1409 (fig-forth-auto680):03837 FDB ZBRAN
+1F83 0013 (fig-forth-auto680):03838 FDB NUMB2-*-NATWID
+1F85 1742177B13A7 (fig-forth-auto680):03839 FDB DUP,CAT,LIT8
+1F8B 2E (fig-forth-auto680):03840 FCC "."
+1F8C 1A01183A1B36183A (fig-forth-auto680):03841 FDB SUB,ZERO,QERR,ZERO,BRAN
+ 13FA
+1F96 FFDB (fig-forth-auto680):03842 FDB NUMB1-*-NATWID
+1F98 1725168B1409 (fig-forth-auto680):03843 NUMB2 FDB DROP,FROMR,ZBRAN
+1F9E 0002 (fig-forth-auto680):03844 FDB NUMB3-*-NATWID
+1FA0 16FD (fig-forth-auto680):03845 FDB DMINUS
+1FA2 1662 (fig-forth-auto680):03846 NUMB3 FDB SEMIS
+ (fig-forth-auto680):03847 *
+ (fig-forth-auto680):03848 * ======>> 141 <<
+ (fig-forth-auto680):03849 * ( --- locptr length true ) { -FIND name } typical input
+ (fig-forth-auto680):03850 * ( --- false )
+ (fig-forth-auto680):03851 * Parse a word, then FIND,
+ (fig-forth-auto680):03852 * first in the definition vocabulary,
+ (fig-forth-auto680):03853 * then in the CONTEXT (interpretation) vocabulary, if necessary.
+ (fig-forth-auto680):03854 * Returns what (FIND) returns, flag and optional location and length.
+1FA4 85 (fig-forth-auto680):03855 FCB $85
+1FA5 2D46494E (fig-forth-auto680):03856 FCC '-FIN' ; '-FIND'
+1FA9 C4 (fig-forth-auto680):03857 FCB $C4
+1FAA 1F4D (fig-forth-auto680):03858 FDB NUMB-9
+1FAC 17B6185B1EBB19C4 (fig-forth-auto680):03859 DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
+ 193B176F176F
+1FBA 14AF1742169E1409 (fig-forth-auto680):03860 FDB PFIND,DUP,ZEQU,ZBRAN
+1FC2 0008 (fig-forth-auto680):03861 FDB DFIND2-*-NATWID
+1FC4 172519C41ACD14AF (fig-forth-auto680):03862 FDB DROP,HERE,LATEST,PFIND
+1FCC 1662 (fig-forth-auto680):03863 DFIND2 FDB SEMIS
+ (fig-forth-auto680):03864 *
+ (fig-forth-auto680):03865 * ######>> screen 50 <<
+ (fig-forth-auto680):03866 * ======>> 142 <<
+ (fig-forth-auto680):03867 * ( anything --- nothing ) ( anything *** nothing )
+ (fig-forth-auto680):03868 * An indirection for ABORT, for ERROR,
+ (fig-forth-auto680):03869 * which may be modified carefully.
+1FCE 87 (fig-forth-auto680):03870 FCB $87
+1FCF 2841424F5254 (fig-forth-auto680):03871 FCC '(ABORT' ; '(ABORT)'
+1FD5 A9 (fig-forth-auto680):03872 FCB $A9
+1FD6 1FA4 (fig-forth-auto680):03873 FDB DFIND-8
+1FD8 17B62204 (fig-forth-auto680):03874 PABORT FDB DOCOL,ABORT
+1FDC 1662 (fig-forth-auto680):03875 FDB SEMIS
+ (fig-forth-auto680):03876 *
+ (fig-forth-auto680):03877 * ======>> 143 <<
+1FDE 85 (fig-forth-auto680):03878 FCB $85
+1FDF 4552524F (fig-forth-auto680):03879 FCC 'ERRO' ; 'ERROR'
+1FE3 D2 (fig-forth-auto680):03880 FCB $D2
+1FE4 1FCE (fig-forth-auto680):03881 FDB PABORT-10
+ (fig-forth-auto680):03882 * This really should not be high level, according to best practices.
+ (fig-forth-auto680):03883 * But fixing that cascades through MESSAGE,
+ (fig-forth-auto680):03884 * requiring re-architecting the disk block system.
+ (fig-forth-auto680):03885 * First, we need to get this transliteration running.
+1FE6 17B618D5176F16B0 (fig-forth-auto680):03886 ERROR FDB DOCOL,WARN,AT,ZLESS
+1FEE 1409 (fig-forth-auto680):03887 FDB ZBRAN
+1FF0 0002 (fig-forth-auto680):03888 FDB ERROR2-*-NATWID
+ (fig-forth-auto680):03889 * note: WARNING is
+ (fig-forth-auto680):03890 * -1 to abort,
+ (fig-forth-auto680):03891 * 0 to print error #
+ (fig-forth-auto680):03892 * and 1 to print error message from disc
+1FF2 1FD8 (fig-forth-auto680):03893 FDB PABORT
+1FF4 19C41C971CAA1D0B (fig-forth-auto680):03894 ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
+1FFC 0407 (fig-forth-auto680):03895 FCB 4,7 ( bell )
+1FFE 203F20 (fig-forth-auto680):03896 FCC " ? "
+2001 252A1648190C176F (fig-forth-auto680):03897 FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
+ 1903176F21D6
+200F 1662 (fig-forth-auto680):03898 FDB SEMIS
+ (fig-forth-auto680):03899 *
+ (fig-forth-auto680):03900 * ======>> 144 <<
+ (fig-forth-auto680):03901 * ( n adr --- )
+ (fig-forth-auto680):03902 * Mask byte at adr with n.
+ (fig-forth-auto680):03903 * Not in FIG, don't need it for 8 bit characters after all.
+ (fig-forth-auto680):03904 * FCB $85
+ (fig-forth-auto680):03905 * FCC 'CMAS' ; 'CMASK'
+ (fig-forth-auto680):03906 * FCB $CB ; 'K'
+ (fig-forth-auto680):03907 * FDB ERROR-8
+ (fig-forth-auto680):03908 * CMASK FDB *+NATWID
+ (fig-forth-auto680):03909 * LDX ,U++ ; adr
+ (fig-forth-auto680):03910 * LDD ,U++ ; mask
+ (fig-forth-auto680):03911 * ANDB ,X
+ (fig-forth-auto680):03912 * STB ,X
+ (fig-forth-auto680):03913 * RTS
+ (fig-forth-auto680):03914 *
+ (fig-forth-auto680):03915 * ( adr --- adr )
+ (fig-forth-auto680):03916 * Mask high bit of tail of name in PAD buffer.
+ (fig-forth-auto680):03917 * Not in FIG, need it for 8 bit characters.
+2011 86 (fig-forth-auto680):03918 FCB $86
+2012 4944464C41 (fig-forth-auto680):03919 FCC 'IDFLA' ; 'IDFLAT'
+2017 D4 (fig-forth-auto680):03920 FCB $D4 ; 'T'
+2018 1FDE (fig-forth-auto680):03921 FDB ERROR-8
+201A 201C (fig-forth-auto680):03922 IDFLAT FDB *+NATWID
+201C AEC4 (fig-forth-auto680):03923 LDX ,U
+201E E684 (fig-forth-auto680):03924 LDB ,X ; get the count
+2020 C43F (fig-forth-auto680):03925 ANDB #CTMASK
+2022 A685 (fig-forth-auto680):03926 LDA B,X ; point to the tail
+2024 847F (fig-forth-auto680):03927 ANDA #$7F ; Clear the EndOfName flag bit.
+2026 A785 (fig-forth-auto680):03928 STA B,X
+2028 39 (fig-forth-auto680):03929 RTS
+ (fig-forth-auto680):03930 *
+ (fig-forth-auto680):03931 * ( symptr --- )
+ (fig-forth-auto680):03932 * Print definition's name from its NFA.
+2029 83 (fig-forth-auto680):03933 FCB $83
+202A 4944 (fig-forth-auto680):03934 FCC 'ID' ; 'ID.'
+202C AE (fig-forth-auto680):03935 FCB $AE
+202D 2011 (fig-forth-auto680):03936 FDB IDFLAT-9
+202F 17B61EA913A7 (fig-forth-auto680):03937 IDDOT FDB DOCOL,PAD,LIT8
+2035 20 (fig-forth-auto680):03938 FCB 32
+2036 13A7 (fig-forth-auto680):03939 FDB LIT8
+2038 5F (fig-forth-auto680):03940 FCB $5F ( underline )
+2039 1E5117421B0F1ADD (fig-forth-auto680):03941 FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
+ 17171A011EA9
+ (fig-forth-auto680):03942 * FDB SWAP,CMOVE,PAD,COUNT,LIT8
+2047 173315831EA9 (fig-forth-auto680):03943 FDB SWAP,CMOVE,PAD
+204D 201A (fig-forth-auto680):03944 FDB IDFLAT
+204F 1C9713A7 (fig-forth-auto680):03945 FDB COUNT,LIT8
+2053 1F (fig-forth-auto680):03946 FCB 31
+2054 16091CAA1A54 (fig-forth-auto680):03947 FDB AND,TYPE,SPACE
+205A 1662 (fig-forth-auto680):03948 FDB SEMIS
+ (fig-forth-auto680):03949 *
+ (fig-forth-auto680):03950 * ######>> screen 51 <<
+ (fig-forth-auto680):03951 * ======>> 145 <<
+ (fig-forth-auto680):03952 * ( --- ) { CREATE name } input
+ (fig-forth-auto680):03953 * Parse a name (length < 32 characters) and create a header,
+ (fig-forth-auto680):03954 * reporting first duplicate found in either the defining vocabulary
+ (fig-forth-auto680):03955 * or the context (interpreting) vocabulary.
+ (fig-forth-auto680):03956 * Install the header in the defining vocabulary
+ (fig-forth-auto680):03957 * with CFA dangerously pointing to the parameter field.
+ (fig-forth-auto680):03958 * Leave the name SMUDGEd.
+205C 86 (fig-forth-auto680):03959 FCB $86
+205D 4352454154 (fig-forth-auto680):03960 FCC 'CREAT' ; 'CREATE'
+2062 C5 (fig-forth-auto680):03961 FCB $C5
+2063 2029 (fig-forth-auto680):03962 FDB IDDOT-6
+2065 17B61FAC1409 (fig-forth-auto680):03963 CREATE FDB DOCOL,DFIND,ZBRAN
+206B 0018 (fig-forth-auto680):03964 FDB CREAT2-*-NATWID
+206D 17251D0B (fig-forth-auto680):03965 FDB DROP,PDOTQ
+2071 08 (fig-forth-auto680):03966 FCB 8
+2072 07 (fig-forth-auto680):03967 FCB 7 ( bel )
+2073 72656465663A20 (fig-forth-auto680):03968 FCC "redef: "
+207A 1AFA202F13A7 (fig-forth-auto680):03969 FDB NFA,IDDOT,LIT8
+2080 04 (fig-forth-auto680):03970 FCB 4
+2081 252A1A54 (fig-forth-auto680):03971 FDB MESS,SPACE
+2085 19C41742177B18C7 (fig-forth-auto680):03972 CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
+ 176F1A62
+2091 19A819D4174213A7 (fig-forth-auto680):03973 FDB ONEP,ALLOT,DUP,LIT8
+2099 A0 (fig-forth-auto680):03974 FCB ($80|FSMUDG) ; Bracket the name.
+209A 176219C418421A01 (fig-forth-auto680):03975 FDB TOGGLE,HERE,ONE,SUB,LIT8
+ 13A7
+20A4 80 (fig-forth-auto680):03976 FCB $80
+20A5 17621ACD19E01949 (fig-forth-auto680):03977 FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
+ 176F1787
+ (fig-forth-auto680):03978 * FDB HERE,TWOP,COMMA
+20B1 19C417FF19E0 (fig-forth-auto680):03979 FDB HERE,NATP,COMMA
+20B7 1662 (fig-forth-auto680):03980 FDB SEMIS
+ (fig-forth-auto680):03981 *
+ (fig-forth-auto680):03982 * ######>> screen 52 <<
+ (fig-forth-auto680):03983 * ======>> 146 <<
+ (fig-forth-auto680):03984 * ( --- ) P
+ (fig-forth-auto680):03985 * { [COMPILE] name } typical use
+ (fig-forth-auto680):03986 * -DFIND next WORD and COMPILE it, literally;
+ (fig-forth-auto680):03987 * used to compile immediate definitions into words.
+20B9 C9 (fig-forth-auto680):03988 FCB $C9 immediate
+20BA 5B434F4D50494C45 (fig-forth-auto680):03989 FCC '[COMPILE' ; '[COMPILE]'
+20C2 DD (fig-forth-auto680):03990 FCB $DD
+20C3 205C (fig-forth-auto680):03991 FDB CREATE-9
+20C5 17B61FAC169E183A (fig-forth-auto680):03992 BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
+ 1B3617251AEC19E0
+20D5 1662 (fig-forth-auto680):03993 FDB SEMIS
+ (fig-forth-auto680):03994 *
+ (fig-forth-auto680):03995 * ======>> 147 <<
+ (fig-forth-auto680):03996 * ( n --- ) if compiling. P
+ (fig-forth-auto680):03997 * ( n --- n ) if interpreting.
+ (fig-forth-auto680):03998 * Compile n as a literal, if compiling.
+20D7 C7 (fig-forth-auto680):03999 FCB $C7 immediate
+20D8 4C4954455241 (fig-forth-auto680):04000 FCC 'LITERA' ; 'LITERAL'
+20DE CC (fig-forth-auto680):04001 FCB $CC
+20DF 20B9 (fig-forth-auto680):04002 FDB BCOMP-12
+20E1 17B61955176F1409 (fig-forth-auto680):04003 LITER FDB DOCOL,STATE,AT,ZBRAN
+20E9 0006 (fig-forth-auto680):04004 FDB LITER2-*-NATWID
+20EB 1BC4139919E0 (fig-forth-auto680):04005 FDB COMPIL,LIT,COMMA
+20F1 1662 (fig-forth-auto680):04006 LITER2 FDB SEMIS
+ (fig-forth-auto680):04007 *
+ (fig-forth-auto680):04008 * ======>> 148 <<
+ (fig-forth-auto680):04009 * ( d --- ) if compiling. P
+ (fig-forth-auto680):04010 * ( d --- d ) if interpreting.
+ (fig-forth-auto680):04011 * Compile d as a double literal, if compiling.
+20F3 C8 (fig-forth-auto680):04012 FCB $C8 immediate
+20F4 444C4954455241 (fig-forth-auto680):04013 FCC 'DLITERA' ; 'DLITERAL'
+20FB CC (fig-forth-auto680):04014 FCB $CC
+20FC 20D7 (fig-forth-auto680):04015 FDB LITER-10
+20FE 17B61955176F1409 (fig-forth-auto680):04016 DLITER FDB DOCOL,STATE,AT,ZBRAN
+2106 0006 (fig-forth-auto680):04017 FDB DLITE2-*-NATWID
+2108 173320E120E1 (fig-forth-auto680):04018 FDB SWAP,LITER,LITER ; Just two literals in the right order.
+210E 1662 (fig-forth-auto680):04019 DLITE2 FDB SEMIS
+ (fig-forth-auto680):04020 *
+ (fig-forth-auto680):04021 * ######>> screen 53 <<
+ (fig-forth-auto680):04022 * ======>> 149 <<
+ (fig-forth-auto680):04023 * ( --- )
+ (fig-forth-auto680):04024 * Interpret or compile, according to STATE.
+ (fig-forth-auto680):04025 * Searches words parsed in dictionary first, via -FIND,
+ (fig-forth-auto680):04026 * then checks for valid NUMBER.
+ (fig-forth-auto680):04027 * Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
+ (fig-forth-auto680):04028 * ERROR checks the stack via ?STACK before returning to its caller.
+2110 89 (fig-forth-auto680):04029 FCB $89
+2111 494E544552505245 (fig-forth-auto680):04030 FCC 'INTERPRE' ; 'INTERPRET'
+2119 D4 (fig-forth-auto680):04031 FCB $D4
+211A 20F3 (fig-forth-auto680):04032 FDB DLITER-11
+211C 17B6 (fig-forth-auto680):04033 INTERP FDB DOCOL
+211E 1FAC1409 (fig-forth-auto680):04034 INTER2 FDB DFIND,ZBRAN
+2122 001A (fig-forth-auto680):04035 FDB INTER5-*-NATWID
+2124 1955176F1A1A (fig-forth-auto680):04036 FDB STATE,AT,LESS
+212A 1409 (fig-forth-auto680):04037 FDB ZBRAN
+212C 0008 (fig-forth-auto680):04038 FDB INTER3-*-NATWID
+212E 1AEC19E013FA (fig-forth-auto680):04039 FDB CFA,COMMA,BRAN
+2134 0004 (fig-forth-auto680):04040 FDB INTER4-*-NATWID
+2136 1AEC13EB (fig-forth-auto680):04041 INTER3 FDB CFA,EXEC
+213A 13FA (fig-forth-auto680):04042 INTER4 FDB BRAN
+213C 0018 (fig-forth-auto680):04043 FDB INTER7-*-NATWID
+213E 19C41F56196A176F (fig-forth-auto680):04044 INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
+ 19A81409
+214A 0006 (fig-forth-auto680):04045 FDB INTER6-*-NATWID
+214C 20FE13FA (fig-forth-auto680):04046 FDB DLITER,BRAN
+2150 0004 (fig-forth-auto680):04047 FDB INTER7-*-NATWID
+2152 172520E1 (fig-forth-auto680):04048 INTER6 FDB DROP,LITER
+2156 1D5613FA (fig-forth-auto680):04049 INTER7 FDB QSTACK,BRAN
+215A FFC2 (fig-forth-auto680):04050 FDB INTER2-*-NATWID
+ (fig-forth-auto680):04051 * FDB SEMIS never executed
+ (fig-forth-auto680):04052
+ (fig-forth-auto680):04053 *
+ (fig-forth-auto680):04054 * ######>> screen 54 <<
+ (fig-forth-auto680):04055 * ======>> 150 <<
+ (fig-forth-auto680):04056 * ( --- )
+ (fig-forth-auto680):04057 * Toggle precedence bit of LATEST definition header.
+ (fig-forth-auto680):04058 * During compiling, most symbols scanned are compiled.
+ (fig-forth-auto680):04059 * IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
+ (fig-forth-auto680):04060 * but may be compiled via ' (TICK).
+215C 89 (fig-forth-auto680):04061 FCB $89
+215D 494D4D4544494154 (fig-forth-auto680):04062 FCC 'IMMEDIAT' ; 'IMMEDIATE'
+2165 C5 (fig-forth-auto680):04063 FCB $C5
+2166 2110 (fig-forth-auto680):04064 FDB INTERP-12
+2168 17B61ACD13A7 (fig-forth-auto680):04065 IMMED FDB DOCOL,LATEST,LIT8
+216E 40 (fig-forth-auto680):04066 FCB FIMMED
+216F 1762 (fig-forth-auto680):04067 FDB TOGGLE
+2171 1662 (fig-forth-auto680):04068 FDB SEMIS
+ (fig-forth-auto680):04069 *
+ (fig-forth-auto680):04070 * ======>> 151 <<
+ (fig-forth-auto680):04071 * ( --- ) { VOCABULARY name } input
+ (fig-forth-auto680):04072 * Create a vocabulary entry with a flag for terminating vocabulary searches.
+ (fig-forth-auto680):04073 * Store the current search context in it for linking.
+ (fig-forth-auto680):04074 * At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
+2173 8A (fig-forth-auto680):04075 FCB $8A
+2174 564F434142554C41 (fig-forth-auto680):04076 FCC 'VOCABULAR' ; 'VOCABULARY'
+ 52
+217D D9 (fig-forth-auto680):04077 FCB $D9
+217E 215C (fig-forth-auto680):04078 FDB IMMED-12
+2180 17B61C65139981A0 (fig-forth-auto680):04079 VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
+ 19E01949176F1AEC
+2190 19E019C418F9176F (fig-forth-auto680):04080 FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
+ 19E018F917871C75
+ (fig-forth-auto680):04081 * DOVOC FDB TWOP,CONTXT,STORE
+21A0 17FF193B1787 (fig-forth-auto680):04082 DOVOC FDB NATP,CONTXT,STORE
+21A6 1662 (fig-forth-auto680):04083 FDB SEMIS
+ (fig-forth-auto680):04084 *
+ (fig-forth-auto680):04085 * ======>> 152 <<
+ (fig-forth-auto680):04086 *
+ (fig-forth-auto680):04087 * Note: FORTH does not go here in the rom-able dictionary,
+ (fig-forth-auto680):04088 * since FORTH is a type of variable.
+ (fig-forth-auto680):04089 *
+ (fig-forth-auto680):04090 * (Should make a proper architecture for this at some point.)
+ (fig-forth-auto680):04091 *
+ (fig-forth-auto680):04092 *
+ (fig-forth-auto680):04093 * ======>> 153 <<
+ (fig-forth-auto680):04094 * ( --- )
+ (fig-forth-auto680):04095 * Makes the current interpretation CONTEXT vocabulary
+ (fig-forth-auto680):04096 * also the CURRENT defining vocabulary.
+21A8 8B (fig-forth-auto680):04097 FCB $8B
+21A9 444546494E495449 (fig-forth-auto680):04098 FCC 'DEFINITION' ; 'DEFINITIONS'
+ 4F4E
+21B3 D3 (fig-forth-auto680):04099 FCB $D3
+21B4 2173 (fig-forth-auto680):04100 FDB VOCAB-13
+21B6 17B6193B176F1949 (fig-forth-auto680):04101 DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
+ 1787
+21C0 1662 (fig-forth-auto680):04102 FDB SEMIS
+ (fig-forth-auto680):04103 *
+ (fig-forth-auto680):04104 * ======>> 154 <<
+ (fig-forth-auto680):04105 * ( --- )
+ (fig-forth-auto680):04106 * Parse out a comment and toss it away.
+ (fig-forth-auto680):04107 * Leaves the first 32 characters in WORDPAD, which may or may not be useful.
+21C2 C1 (fig-forth-auto680):04108 FCB $C1 immediate (
+21C3 A8 (fig-forth-auto680):04109 FCB $A8
+21C4 21A8 (fig-forth-auto680):04110 FDB DEFIN-14
+21C6 17B613A7 (fig-forth-auto680):04111 PAREN FDB DOCOL,LIT8
+21CA 29 (fig-forth-auto680):04112 FCC ")"
+21CB 1EBB (fig-forth-auto680):04113 FDB WORD
+21CD 1662 (fig-forth-auto680):04114 FDB SEMIS
+ (fig-forth-auto680):04115 *
+ (fig-forth-auto680):04116 * ######>> screen 55 <<
+ (fig-forth-auto680):04117 * ======>> 155 <<
+ (fig-forth-auto680):04118 * ( anything *** nothing )
+ (fig-forth-auto680):04119 * Clear return stack.
+ (fig-forth-auto680):04120 * Then INTERPRET and, if not compiling, prompt with OK,
+ (fig-forth-auto680):04121 * in infinite loop.
+21CF 84 (fig-forth-auto680):04122 FCB $84
+21D0 515549 (fig-forth-auto680):04123 FCC 'QUI' ; 'QUIT'
+21D3 D4 (fig-forth-auto680):04124 FCB $D4
+21D4 21C2 (fig-forth-auto680):04125 FDB PAREN-4
+21D6 17B6183A19031787 (fig-forth-auto680):04126 QUIT FDB DOCOL,ZERO,BLK,STORE
+21DE 1BD8 (fig-forth-auto680):04127 FDB LBRAK
+ (fig-forth-auto680):04128 *
+ (fig-forth-auto680):04129 * Here is the outer interpretter
+ (fig-forth-auto680):04130 * which gets a line of input, does it, prints " OK"
+ (fig-forth-auto680):04131 * then repeats :
+21E0 165315761DFA211C (fig-forth-auto680):04132 QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
+ 1955176F169E
+21EE 1409 (fig-forth-auto680):04133 FDB ZBRAN
+21F0 0006 (fig-forth-auto680):04134 FDB QUIT3-*-NATWID
+21F2 1D0B (fig-forth-auto680):04135 FDB PDOTQ
+21F4 03 (fig-forth-auto680):04136 FCB 3
+21F5 204F4B (fig-forth-auto680):04137 FCC ' OK' ; ' OK'
+21F8 13FA (fig-forth-auto680):04138 QUIT3 FDB BRAN
+21FA FFE4 (fig-forth-auto680):04139 FDB QUIT2-*-NATWID
+ (fig-forth-auto680):04140 * FDB SEMIS ( never executed )
+ (fig-forth-auto680):04141 *
+ (fig-forth-auto680):04142 * ======>> 156 <<
+ (fig-forth-auto680):04143 * ( anything --- nothing ) ( anything *** nothing )
+ (fig-forth-auto680):04144 * Clear parameter stack,
+ (fig-forth-auto680):04145 * set STATE to interpret and BASE to DECIMAL,
+ (fig-forth-auto680):04146 * return to input from terminal,
+ (fig-forth-auto680):04147 * restore DRIVE OFFSET to 0,
+ (fig-forth-auto680):04148 * print out "Forth-68",
+ (fig-forth-auto680):04149 * set interpret and define vocabularies to FORTH,
+ (fig-forth-auto680):04150 * and finally, QUIT.
+ (fig-forth-auto680):04151 * Used to force the system to a known state
+ (fig-forth-auto680):04152 * and return control to the initial INTERPRETer.
+21FC 85 (fig-forth-auto680):04153 FCB $85
+21FD 41424F52 (fig-forth-auto680):04154 FCC 'ABOR' ; 'ABORT'
+2201 D4 (fig-forth-auto680):04155 FCB $D4
+2202 21CF (fig-forth-auto680):04156 FDB QUIT-7
+2204 17B616481C201D56 (fig-forth-auto680):04157 ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
+ 242415761D0B
+2212 0A (fig-forth-auto680):04158 FCB 10
+2213 466F7274682D3638 (fig-forth-auto680):04159 FCC "Forth-6809"
+ 3039
+221D 29FE21B6 (fig-forth-auto680):04160 FDB FORTH,DEFIN
+2221 21D6 (fig-forth-auto680):04161 FDB QUIT
+ (fig-forth-auto680):04162 * FDB SEMIS never executed
+ (fig-forth-auto680):04163 PAGE
+ (fig-forth-auto680):04164 *
+ (fig-forth-auto680):04165 * ######>> screen 56 <<
+ (fig-forth-auto680):04166 * bootstrap code... moves rom contents to ram :
+ (fig-forth-auto680):04167 * ======>> 157 <<
+2223 84 (fig-forth-auto680):04168 FCB $84
+2224 434F4C (fig-forth-auto680):04169 FCC 'COL' ; 'COLD'
+2227 C4 (fig-forth-auto680):04170 FCB $C4
+2228 21FC (fig-forth-auto680):04171 FDB ABORT-8
+222A 222C (fig-forth-auto680):04172 COLD FDB *+NATWID
+ (fig-forth-auto680):04173 * Ultimately, we want position indepence,
+ (fig-forth-auto680):04174 * so I'm using PCR where it seems reasonable.
+222C 10EE8DEFE1 (fig-forth-auto680):04175 CENT LDS SINIT,PCR ; Get a useable return stack, at least.
+2231 867C (fig-forth-auto680):04176 LDA #IUPDP ; This is not relative to PC.
+2233 1F8B (fig-forth-auto680):04177 TFR A,DP ; And a useable direct page, too.
+ 7C (fig-forth-auto680):04178 SETDP IUPDP ; (For good measure.)
+ (fig-forth-auto680):04179 *
+ (fig-forth-auto680):04180 * We'll keep this here for the time being.
+ (fig-forth-auto680):04181 * There are better ways to do this, of course.
+ (fig-forth-auto680):04182 * Re-architect, re-architect.
+2235 308D006A (fig-forth-auto680):04183 LEAX RAM,PCR
+2239 9F28 (fig-forth-auto680):04184 STX <XFENCE ; Borrow this variable for a loop terminator.
+223B 318D07F2 (fig-forth-auto680):04185 LEAY REND,PCR ; top of destination
+223F 308D00A3 (fig-forth-auto680):04186 LEAX ERAM,PCR ; top of stuff to move
+2243 A682 (fig-forth-auto680):04187 COLD2 LDA ,-X
+2245 A7A2 (fig-forth-auto680):04188 STA ,-Y ; move TASK & FORTH to ram
+2247 9C28 (fig-forth-auto680):04189 CMPX <XFENCE
+2249 26F8 (fig-forth-auto680):04190 BNE COLD2
+ (fig-forth-auto680):04191 *
+ (fig-forth-auto680):04192 * CENT LDS #REND-1 top of destination
+ (fig-forth-auto680):04193 * LDX #ERAM top of stuff to move
+ (fig-forth-auto680):04194 * COLD2 LEAX -1,X ;
+ (fig-forth-auto680):04195 * LDA 0,X
+ (fig-forth-auto680):04196 * PSHS A ; move TASK & FORTH to ram
+ (fig-forth-auto680):04197 * CMPX #RAM
+ (fig-forth-auto680):04198 * BNE COLD2
+ (fig-forth-auto680):04199 *
+ (fig-forth-auto680):04200 * LDS #XFENCE-1 put stack at a safe place for now
+ (fig-forth-auto680):04201 * But that is taken care of.
+ (fig-forth-auto680):04202 * LDX COLINT
+ (fig-forth-auto680):04203 * STX XCOLUM
+224B AE8DEFD3 (fig-forth-auto680):04204 LDX COLINT,PCR
+224F 9F4C (fig-forth-auto680):04205 STX <XCOLUM
+ (fig-forth-auto680):04206 * LDX DELINT
+ (fig-forth-auto680):04207 * STX XDELAY
+2251 AE8DEFCF (fig-forth-auto680):04208 LDX DELINT,PCR
+2255 9F4A (fig-forth-auto680):04209 STX <XDELAY
+ (fig-forth-auto680):04210 * LDX VOCINT
+ (fig-forth-auto680):04211 * STX XVOCL
+2257 AE8DEFC5 (fig-forth-auto680):04212 LDX VOCINT,PCR
+225B 9F2C (fig-forth-auto680):04213 STX <XVOCL
+ (fig-forth-auto680):04214 * LDX DPINIT
+ (fig-forth-auto680):04215 * STX XDICTP
+225D AE8DEFBD (fig-forth-auto680):04216 LDX DPINIT,PCR
+2261 9F2A (fig-forth-auto680):04217 STX <XDICTP
+ (fig-forth-auto680):04218 * LDX FENCIN
+ (fig-forth-auto680):04219 * STX XFENCE
+2263 AE8DEFB5 (fig-forth-auto680):04220 LDX FENCIN,PCR
+2267 9F28 (fig-forth-auto680):04221 STX <XFENCE
+ (fig-forth-auto680):04222 *
+2269 10EE8DEFA4 (fig-forth-auto680):04223 WENT LDS SINIT,PCR ; Get a useable return stack, at least.
+226E 867C (fig-forth-auto680):04224 LDA #IUPDP ; This is not relative to PC.
+2270 1F8B (fig-forth-auto680):04225 TFR A,DP ; And a useable direct page, too.
+ 7C (fig-forth-auto680):04226 SETDP IUPDP ; (For good measure.)
+ (fig-forth-auto680):04227 *
+2272 308DEF9C (fig-forth-auto680):04228 LEAX SINIT,PCR
+2276 3410 (fig-forth-auto680):04229 PSHS X ; for loop termination
+2278 5F (fig-forth-auto680):04230 CLRB ; Yes, I'm being a little ridiculous. Only a little.
+2279 1F02 (fig-forth-auto680):04231 TFR D,Y
+227B 31A828 (fig-forth-auto680):04232 LEAY XFENCE-UORIG,Y ; top of destination
+227E 308DEF9A (fig-forth-auto680):04233 LEAX FENCIN,PCR ; top of stuff to move
+2282 EC83 (fig-forth-auto680):04234 WARM2 LDD ,--X ; All entries are 16 bit.
+2284 EDA3 (fig-forth-auto680):04235 STD ,--Y
+2286 ACE4 (fig-forth-auto680):04236 CMPX ,S
+2288 26F8 (fig-forth-auto680):04237 BNE WARM2
+228A 3262 (fig-forth-auto680):04238 LEAS 2,S ; But we'll reset the return stack shortly, anyway.
+ (fig-forth-auto680):04239 * WENT LDS #XFENCE-1 top of destination
+ (fig-forth-auto680):04240 * LDX #FENCIN top of stuff to move
+ (fig-forth-auto680):04241 * WARM2 LEAX -1,X ;
+ (fig-forth-auto680):04242 * LDA 0,X
+ (fig-forth-auto680):04243 * PSHS A ;
+ (fig-forth-auto680):04244 * CMPX #SINIT
+ (fig-forth-auto680):04245 * BNE WARM2
+ (fig-forth-auto680):04246 *
+ (fig-forth-auto680):04247 * LDS SINIT
+ (fig-forth-auto680):04248 * S is already there.
+ (fig-forth-auto680):04249 * LDX UPINIT
+ (fig-forth-auto680):04250 * STX UP init user ram pointer
+ (fig-forth-auto680):04251 * UP is already there (DP).
+ (fig-forth-auto680):04252 * LDX #ABORT
+ (fig-forth-auto680):04253 * STX IP
+228C 318DFF76 (fig-forth-auto680):04254 LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
+ (fig-forth-auto680):04255 *
+2290 12 (fig-forth-auto680):04256 NOP Here is a place to jump to special user
+2291 12 (fig-forth-auto680):04257 NOP initializations such as I/0 interrups
+2292 12 (fig-forth-auto680):04258 NOP
+ (fig-forth-auto680):04259 *
+ (fig-forth-auto680):04260 * For systems with TRACE:
+2293 8E0000 (fig-forth-auto680):04261 LDX #00
+ (fig-forth-auto680):04262 * STX TRLIM clear trace mode
+2296 9F0A (fig-forth-auto680):04263 STX <TRLIM clear trace mode (both bytes)
+2298 8E0000 (fig-forth-auto680):04264 LDX #0
+ (fig-forth-auto680):04265 * STX BRKPT clear breakpoint address
+229B 9F0C (fig-forth-auto680):04266 STX <BRKPT clear breakpoint address
+ (fig-forth-auto680):04267 * JMP RPSTOR+2 start the virtual machine running !
+229D 17F3B5 (fig-forth-auto680):04268 LBSR RPSTOR+NATWID start the virtual machine running !
+22A0 16EF85 (fig-forth-auto680):04269 LBRA NEXT ; But we must also give RP! someplace to return.
+ (fig-forth-auto680):04270 * RP! sets up the return stack pointer, then Y references abort.
+ (fig-forth-auto680):04271 *
+ (fig-forth-auto680):04272 * Here is the stuff that gets copied to ram :
+ (fig-forth-auto680):04273 * (not * at address $140:)
+ (fig-forth-auto680):04274 * at an appropriate address:
+ (fig-forth-auto680):04275 *
+22A3 3000300000000000 (fig-forth-auto680):04276 RAM FDB $3000,$3000,0,0
+ (fig-forth-auto680):04277
+ (fig-forth-auto680):04278 * ======>> (152) <<
+ (fig-forth-auto680):04279 * ( --- ) P
+ (fig-forth-auto680):04280 * Makes FORTH the current interpretation vocabulary.
+ (fig-forth-auto680):04281 * In order to make this ROMmable, this entry is set up as the tail-end,
+ (fig-forth-auto680):04282 * and copied to RAM in the start-up code.
+ (fig-forth-auto680):04283 * We want a more elegant solution to this, too. Greedy, maybe.
+22AB C5 (fig-forth-auto680):04284 FCB $C5 immediate
+22AC 464F5254 (fig-forth-auto680):04285 FCC 'FORT' ; 'FORTH'
+22B0 C8 (fig-forth-auto680):04286 FCB $C8
+22B1 29DD (fig-forth-auto680):04287 FDB NOOP-7 ; Note that this does not link to COLD!
+22B3 1C8121A081A02A26 (fig-forth-auto680):04288 RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
+22BB 0000 (fig-forth-auto680):04289 FDB 0
+22BD 28432920466F7274 (fig-forth-auto680):04290 FCC "(C) Forth Interest Group, 1979"
+ 6820496E74657265
+ 73742047726F7570
+ 2C2031393739
+22DB 84 (fig-forth-auto680):04291 FCB $84
+22DC 544153 (fig-forth-auto680):04292 FCC 'TAS' ; 'TASK'
+22DF CB (fig-forth-auto680):04293 FCB $CB
+22E0 29F6 (fig-forth-auto680):04294 FDB FORTH-8
+22E2 17B61662 (fig-forth-auto680):04295 RTASK FDB DOCOL,SEMIS
+22E6 4461766964204C69 (fig-forth-auto680):04296 ERAM FCC "David Lion"
+ 6F6E
+ (fig-forth-auto680):04297 PAGE
+ (fig-forth-auto680):04298 *
+ (fig-forth-auto680):04299 * ######>> screen 57 <<
+ (fig-forth-auto680):04300 * ======>> 158 <<
+ (fig-forth-auto680):04301 * ( n0 --- d0 )
+ (fig-forth-auto680):04302 * Sign extend n0 to a double integer.
+22F0 84 (fig-forth-auto680):04303 FCB $84
+22F1 532D3E (fig-forth-auto680):04304 FCC 'S->' ; 'S->D'
+22F4 C4 (fig-forth-auto680):04305 FCB $C4
+22F5 2223 (fig-forth-auto680):04306 FDB COLD-7 ; Note that this does not link to FORTH (RFORTH)!
+22F7 17B6174216B016EA (fig-forth-auto680):04307 STOD FDB DOCOL,DUP,ZLESS,MINUS
+22FF 1662 (fig-forth-auto680):04308 FDB SEMIS
+ (fig-forth-auto680):04309
+ (fig-forth-auto680):04310
+ (fig-forth-auto680):04311 *
+ (fig-forth-auto680):04312 * ======>> 159 <<
+ (fig-forth-auto680):04313 * ( multiplier multiplicand --- product )
+ (fig-forth-auto680):04314 * Signed word multiply.
+2301 81 (fig-forth-auto680):04315 FCB $81 ; *
+2302 AA (fig-forth-auto680):04316 FCB $AA
+2303 22F0 (fig-forth-auto680):04317 FDB STOD-7
+2305 2307 (fig-forth-auto680):04318 STAR FDB *+NATWID
+2307 17F298 (fig-forth-auto680):04319 LBSR USTAR+NATWID ; or [USTAR,PCR]?
+230A 3342 (fig-forth-auto680):04320 LEAU NATWID,U ; Drop high word.
+230C 39 (fig-forth-auto680):04321 RTS
+ (fig-forth-auto680):04322 * JSR USTARS
+ (fig-forth-auto680):04323 * LEAS 1,S ;
+ (fig-forth-auto680):04324 * LEAS 1,S ;
+ (fig-forth-auto680):04325 * JMP NEXT
+ (fig-forth-auto680):04326 *
+ (fig-forth-auto680):04327 * ======>> 160 <<
+ (fig-forth-auto680):04328 * ( dividend divisor --- remainder quotient )
+ (fig-forth-auto680):04329 * M/ in word-only form, i. e., signed division of 2nd word by top word,
+ (fig-forth-auto680):04330 * yielding signed word quotient and remainder.
+230D 84 (fig-forth-auto680):04331 FCB $84
+230E 2F4D4F (fig-forth-auto680):04332 FCC '/MO' ; '/MOD'
+2311 C4 (fig-forth-auto680):04333 FCB $C4
+2312 2301 (fig-forth-auto680):04334 FDB STAR-4
+2314 17B6167C22F7168B (fig-forth-auto680):04335 SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
+ 15D6
+231E 1662 (fig-forth-auto680):04336 FDB SEMIS
+ (fig-forth-auto680):04337 *
+ (fig-forth-auto680):04338 * ======>> 161 <<
+ (fig-forth-auto680):04339 * ( dividend divisor --- quotient )
+ (fig-forth-auto680):04340 * Signed word divide without remainder.
+2320 81 (fig-forth-auto680):04341 FCB $81 ; /
+2321 AF (fig-forth-auto680):04342 FCB $AF
+2322 230D (fig-forth-auto680):04343 FDB SLMOD-7
+2324 17B6231417331725 (fig-forth-auto680):04344 SLASH FDB DOCOL,SLMOD,SWAP,DROP
+232C 1662 (fig-forth-auto680):04345 FDB SEMIS
+ (fig-forth-auto680):04346 *
+ (fig-forth-auto680):04347 * ======>> 162 <<
+ (fig-forth-auto680):04348 * ( dividend divisor --- remainder )
+ (fig-forth-auto680):04349 * Remainder function, result takes sign of dividend.
+232E 83 (fig-forth-auto680):04350 FCB $83
+232F 4D4F (fig-forth-auto680):04351 FCC 'MO' ; 'MOD'
+2331 C4 (fig-forth-auto680):04352 FCB $C4
+2332 2320 (fig-forth-auto680):04353 FDB SLASH-4
+2334 17B623141725 (fig-forth-auto680):04354 MOD FDB DOCOL,SLMOD,DROP
+233A 1662 (fig-forth-auto680):04355 FDB SEMIS
+ (fig-forth-auto680):04356 *
+ (fig-forth-auto680):04357 * ======>> 163 <<
+ (fig-forth-auto680):04358 * ( multiplier multiplicand divisor --- remainder quotient )
+ (fig-forth-auto680):04359 * Signed precise division of product:
+ (fig-forth-auto680):04360 * multiply 2nd and 3rd words on stack
+ (fig-forth-auto680):04361 * and divide the 31-bit product by the top word,
+ (fig-forth-auto680):04362 * leaving both quotient and remainder.
+ (fig-forth-auto680):04363 * Remainder takes sign of product.
+ (fig-forth-auto680):04364 * Guaranteed not to lose significant bits in 16 bit integer math.
+233C 85 (fig-forth-auto680):04365 FCB $85
+233D 2A2F4D4F (fig-forth-auto680):04366 FCC '*/MO' ; '*/MOD'
+2341 C4 (fig-forth-auto680):04367 FCB $C4
+2342 232E (fig-forth-auto680):04368 FDB MOD-6
+2344 17B6167C15A0168B (fig-forth-auto680):04369 SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
+ 15D6
+234E 1662 (fig-forth-auto680):04370 FDB SEMIS
+ (fig-forth-auto680):04371 *
+ (fig-forth-auto680):04372 * ======>> 164 <<
+ (fig-forth-auto680):04373 * ( multiplier multiplicand divisor --- quotient )
+ (fig-forth-auto680):04374 * */MOD without remainder.
+2350 82 (fig-forth-auto680):04375 FCB $82
+2351 2A (fig-forth-auto680):04376 FCC '*' ; '*/'
+2352 AF (fig-forth-auto680):04377 FCB $AF
+2353 233C (fig-forth-auto680):04378 FDB SSMOD-8
+2355 17B6234417331725 (fig-forth-auto680):04379 SSLASH FDB DOCOL,SSMOD,SWAP,DROP
+235D 1662 (fig-forth-auto680):04380 FDB SEMIS
+ (fig-forth-auto680):04381 *
+ (fig-forth-auto680):04382 * ======>> 165 <<
+ (fig-forth-auto680):04383 * ( ud1 u1 --- u2 ud2 )
+ (fig-forth-auto680):04384 * U/ with an (unsigned) double quotient.
+ (fig-forth-auto680):04385 * Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
+ (fig-forth-auto680):04386 * if you are prepared to deal with the extra 16 bits of result.
+235F 85 (fig-forth-auto680):04387 FCB $85
+2360 4D2F4D4F (fig-forth-auto680):04388 FCC 'M/MO' ; 'M/MOD'
+2364 C4 (fig-forth-auto680):04389 FCB $C4
+2365 2350 (fig-forth-auto680):04390 FDB SSLASH-5
+2367 17B6167C183A1697 (fig-forth-auto680):04391 MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
+ 15D6
+2371 168B1733167C15D6 (fig-forth-auto680):04392 FDB FROMR,SWAP,TOR,USLASH,FROMR
+ 168B
+237B 1662 (fig-forth-auto680):04393 FDB SEMIS
+ (fig-forth-auto680):04394 *
+ (fig-forth-auto680):04395 * ======>> 166 <<
+ (fig-forth-auto680):04396 * ( n>=0 --- n )
+ (fig-forth-auto680):04397 * ( n<0 --- -n )
+ (fig-forth-auto680):04398 * Convert the top of stack to its absolute value.
+237D 83 (fig-forth-auto680):04399 FCB $83
+237E 4142 (fig-forth-auto680):04400 FCC 'AB' ; 'ABS'
+2380 D3 (fig-forth-auto680):04401 FCB $D3
+2381 235F (fig-forth-auto680):04402 FDB MSMOD-8
+2383 17B6174216B01409 (fig-forth-auto680):04403 ABS FDB DOCOL,DUP,ZLESS,ZBRAN
+238B 0002 (fig-forth-auto680):04404 FDB ABS2-*-NATWID
+238D 16EA (fig-forth-auto680):04405 FDB MINUS
+238F 1662 (fig-forth-auto680):04406 ABS2 FDB SEMIS
+ (fig-forth-auto680):04407 *
+ (fig-forth-auto680):04408 * ======>> 167 <<
+ (fig-forth-auto680):04409 * ( d>=0 --- d )
+ (fig-forth-auto680):04410 * ( d<0 --- -d )
+ (fig-forth-auto680):04411 * Convert the top double to its absolute value.
+2391 84 (fig-forth-auto680):04412 FCB $84
+2392 444142 (fig-forth-auto680):04413 FCC 'DAB' ; 'DABS'
+2395 D3 (fig-forth-auto680):04414 FCB $D3
+2396 237D (fig-forth-auto680):04415 FDB ABS-6
+2398 17B6174216B01409 (fig-forth-auto680):04416 DABS FDB DOCOL,DUP,ZLESS,ZBRAN
+23A0 0002 (fig-forth-auto680):04417 FDB DABS2-*-NATWID
+23A2 16FD (fig-forth-auto680):04418 FDB DMINUS
+23A4 1662 (fig-forth-auto680):04419 DABS2 FDB SEMIS
+ (fig-forth-auto680):04420 *
+ (fig-forth-auto680):04421 * ######>> screen 58 <<
+ (fig-forth-auto680):04422 * Disc primitives :
+ (fig-forth-auto680):04423 * ======>> 168 <<
+ (fig-forth-auto680):04424 * ( --- vadr )
+ (fig-forth-auto680):04425 * Least Recently Used buffer.
+ (fig-forth-auto680):04426 * Really should be with FIRST and LIMIT in the per-task table.
+23A6 83 (fig-forth-auto680):04427 FCB $83
+23A7 5553 (fig-forth-auto680):04428 FCC 'US' ; 'USE'
+23A9 C5 (fig-forth-auto680):04429 FCB $C5
+23AA 2391 (fig-forth-auto680):04430 FDB DABS-7
+23AC 17E6 (fig-forth-auto680):04431 USE FDB DOCON
+23AE 7C58 (fig-forth-auto680):04432 FDB XUSE
+ (fig-forth-auto680):04433 * ======>> 169 <<
+ (fig-forth-auto680):04434 * ( --- vadr )
+ (fig-forth-auto680):04435 * Most Recently Used buffer.
+ (fig-forth-auto680):04436 * Really should be with FIRST and LIMIT in the per-task table.
+23B0 84 (fig-forth-auto680):04437 FCB $84
+23B1 505245 (fig-forth-auto680):04438 FCC 'PRE' ; 'PREV'
+23B4 D6 (fig-forth-auto680):04439 FCB $D6
+23B5 23A6 (fig-forth-auto680):04440 FDB USE-6
+23B7 17E6 (fig-forth-auto680):04441 PREV FDB DOCON
+23B9 7C5A (fig-forth-auto680):04442 FDB XPREV
+ (fig-forth-auto680):04443 * ======>> 170 <<
+ (fig-forth-auto680):04444 * ( buffer1 --- buffer2 f )
+ (fig-forth-auto680):04445 * Bump to next buffer,
+ (fig-forth-auto680):04446 * flag false if result is PREVious buffer,
+ (fig-forth-auto680):04447 * otherwise flag true.
+ (fig-forth-auto680):04448 * Used in the LRU allocation routines.
+23BB 84 (fig-forth-auto680):04449 FCB $84
+23BC 2B4255 (fig-forth-auto680):04450 FCC '+BU' ; '+BUF'
+23BF C6 (fig-forth-auto680):04451 FCB $C6
+23C0 23B0 (fig-forth-auto680):04452 FDB PREV-7
+23C2 17B613A7 (fig-forth-auto680):04453 PBUF FDB DOCOL,LIT8
+23C6 84 (fig-forth-auto680):04454 FCB $84
+23C7 16C1174218731A0E (fig-forth-auto680):04455 FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
+ 1409
+23D1 0004 (fig-forth-auto680):04456 FDB PBUF2-*-NATWID
+23D3 17251867 (fig-forth-auto680):04457 FDB DROP,FIRST
+23D7 174223B7176F1A01 (fig-forth-auto680):04458 PBUF2 FDB DUP,PREV,AT,SUB
+23DF 1662 (fig-forth-auto680):04459 FDB SEMIS
+ (fig-forth-auto680):04460 *
+ (fig-forth-auto680):04461 * ======>> 171 <<
+ (fig-forth-auto680):04462 * ( --- )
+ (fig-forth-auto680):04463 * Mark PREVious buffer dirty, in need of being written out.
+23E1 86 (fig-forth-auto680):04464 FCB $86
+23E2 5550444154 (fig-forth-auto680):04465 FCC 'UPDAT' ; 'UPDATE'
+23E7 C5 (fig-forth-auto680):04466 FCB $C5
+23E8 23BB (fig-forth-auto680):04467 FDB PBUF-7
+23EA 17B623B7176F176F (fig-forth-auto680):04468 UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
+ 13998000161923B7
+ 176F1787
+23FE 1662 (fig-forth-auto680):04469 FDB SEMIS
+ (fig-forth-auto680):04470 *
+ (fig-forth-auto680):04471 * ======>> 172 <<
+ (fig-forth-auto680):04472 * ( --- )
+ (fig-forth-auto680):04473 * Mark all buffers empty.
+ (fig-forth-auto680):04474 * Standard method of discarding changes.
+2400 8D (fig-forth-auto680):04475 FCB $8D
+2401 454D5054592D4255 (fig-forth-auto680):04476 FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
+ 46464552
+240D D3 (fig-forth-auto680):04477 FCB $D3
+240E 23E1 (fig-forth-auto680):04478 FDB UPDATE-9
+2410 17B6186718731717 (fig-forth-auto680):04479 MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
+ 1A011E71
+241C 1662 (fig-forth-auto680):04480 FDB SEMIS
+ (fig-forth-auto680):04481 *
+ (fig-forth-auto680):04482 * ======>> 173 <<
+ (fig-forth-auto680):04483 * ( --- )
+ (fig-forth-auto680):04484 * Clear the current offset to the block numbers in the drive interface.
+ (fig-forth-auto680):04485 * The drives need to be re-architected.
+ (fig-forth-auto680):04486 * Would be cool to have RAM and ROM drives supported
+ (fig-forth-auto680):04487 * in addition to regular physical persistent store.
+241E 83 (fig-forth-auto680):04488 FCB $83
+241F 4452 (fig-forth-auto680):04489 FCC 'DR' ; 'DR0'
+2421 B0 (fig-forth-auto680):04490 FCB $B0
+2422 2400 (fig-forth-auto680):04491 FDB MTBUF-16
+2424 17B6183A192D1787 (fig-forth-auto680):04492 DRZERO FDB DOCOL,ZERO,OFSET,STORE
+242C 1662 (fig-forth-auto680):04493 FDB SEMIS
+ (fig-forth-auto680):04494 *
+ (fig-forth-auto680):04495 * ======>> 174 <<== system dependant word
+ (fig-forth-auto680):04496 * ( --- )
+ (fig-forth-auto680):04497 * Set the current offset in the drive interface to reference the second drive.
+ (fig-forth-auto680):04498 * The hard-coded number in there needs to be in a table.
+242E 83 (fig-forth-auto680):04499 FCB $83
+242F 4452 (fig-forth-auto680):04500 FCC 'DR' ; 'DR1'
+2431 B1 (fig-forth-auto680):04501 FCB $B1
+2432 241E (fig-forth-auto680):04502 FDB DRZERO-6
+2434 17B6139907D0192D (fig-forth-auto680):04503 DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
+ 1787
+243E 1662 (fig-forth-auto680):04504 FDB SEMIS
+ (fig-forth-auto680):04505 *
+ (fig-forth-auto680):04506 * ######>> screen 59 <<
+ (fig-forth-auto680):04507 * ======>> 175 <<
+ (fig-forth-auto680):04508 * ( n --- buffer )
+ (fig-forth-auto680):04509 * Get a free buffer,
+ (fig-forth-auto680):04510 * assign it to block n,
+ (fig-forth-auto680):04511 * return buffer address.
+ (fig-forth-auto680):04512 * Will free a buffer by writing it, if necessary.
+ (fig-forth-auto680):04513 * Does not actually read the block.
+ (fig-forth-auto680):04514 * A bug in the fig LRU algorithm, which I have not fixed,
+ (fig-forth-auto680):04515 * gives the PREVious buffer if USE gets set to PREVious.
+ (fig-forth-auto680):04516 * (The bug is that USE sometimes gets set to PREVious.)
+ (fig-forth-auto680):04517 * This bug sometimes causes sector moves to become sector fills.
+2440 86 (fig-forth-auto680):04518 FCB $86
+2441 4255464645 (fig-forth-auto680):04519 FCC 'BUFFE' ; 'BUFFER'
+2446 D2 (fig-forth-auto680):04520 FCB $D2
+2447 242E (fig-forth-auto680):04521 FDB DRONE-6
+2449 17B623AC176F1742 (fig-forth-auto680):04522 BUFFER FDB DOCOL,USE,AT,DUP,TOR
+ 167C
+2453 23C21409 (fig-forth-auto680):04523 BUFFR2 FDB PBUF,ZBRAN
+2457 FFFA (fig-forth-auto680):04524 FDB BUFFR2-*-NATWID
+2459 23AC17871697176F (fig-forth-auto680):04525 FDB USE,STORE,R,AT,ZLESS
+ 16B0
+2463 1409 (fig-forth-auto680):04526 FDB ZBRAN
+2465 0012 (fig-forth-auto680):04527 FDB BUFFR3-*-NATWID
+ (fig-forth-auto680):04528 * FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
+2467 169717FF1697176F (fig-forth-auto680):04529 FDB R,NATP,R,AT,LIT,$7FFF,AND,ZERO,RW
+ 13997FFF1609183A
+ 263A
+ (fig-forth-auto680):04530 * BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
+2479 16971787169723B7 (fig-forth-auto680):04531 BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
+ 1787168B17FF
+2487 1662 (fig-forth-auto680):04532 FDB SEMIS
+ (fig-forth-auto680):04533 *
+ (fig-forth-auto680):04534 * ######>> screen 60 <<
+ (fig-forth-auto680):04535 * ======>> 176 <<
+ (fig-forth-auto680):04536 * ( n --- buffer )
+ (fig-forth-auto680):04537 * Get BUFFER containing block n, relative to OFFSET.
+ (fig-forth-auto680):04538 * If block n is not in a buffer, bring it in.
+ (fig-forth-auto680):04539 * Returns buffer address.
+2489 85 (fig-forth-auto680):04540 FCB $85
+248A 424C4F43 (fig-forth-auto680):04541 FCC 'BLOC' ; 'BLOCK'
+248E CB (fig-forth-auto680):04542 FCB $CB
+248F 2440 (fig-forth-auto680):04543 FDB BUFFER-9
+2491 17B6192D176F16C1 (fig-forth-auto680):04544 BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
+ 167C
+249B 23B7176F1742176F (fig-forth-auto680):04545 FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
+ 16971A01174216C1
+ 1409
+24AD 0032 (fig-forth-auto680):04546 FDB BLOCK5-*-NATWID
+24AF 23C2169E1409 (fig-forth-auto680):04547 BLOCK3 FDB PBUF,ZEQU,ZBRAN
+24B5 0012 (fig-forth-auto680):04548 FDB BLOCK4-*-NATWID
+ (fig-forth-auto680):04549 * FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
+24B7 1725169724491742 (fig-forth-auto680):04550 FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
+ 16971842263A17F4
+ 1A01
+24C9 1742176F16971A01 (fig-forth-auto680):04551 BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
+ 174216C1169E1409
+24D9 FFD4 (fig-forth-auto680):04552 FDB BLOCK3-*-NATWID
+24DB 174223B71787 (fig-forth-auto680):04553 FDB DUP,PREV,STORE
+ (fig-forth-auto680):04554 * BLOCK5 FDB FROMR,DROP,TWOP
+24E1 168B172517FF (fig-forth-auto680):04555 BLOCK5 FDB FROMR,DROP,NATP
+24E7 1662 (fig-forth-auto680):04556 FDB SEMIS
+ (fig-forth-auto680):04557 *
+ (fig-forth-auto680):04558 * ######>> screen 61 <<
+ (fig-forth-auto680):04559 * ======>> 177 <<
+ (fig-forth-auto680):04560 * ( line screen --- buffer C/L)
+ (fig-forth-auto680):04561 * Bring in the sector containing the specified line of the specified screen.
+ (fig-forth-auto680):04562 * Returns the buffer address and the width of the screen.
+ (fig-forth-auto680):04563 * Screen number is relative to OFFSET.
+ (fig-forth-auto680):04564 * The line number may be beyond screen 4,
+ (fig-forth-auto680):04565 * (LINE) will get the appropriate screen.
+24E9 86 (fig-forth-auto680):04566 FCB $86
+24EA 284C494E45 (fig-forth-auto680):04567 FCC '(LINE' ; '(LINE)'
+24EF A9 (fig-forth-auto680):04568 FCB $A9
+24F0 2489 (fig-forth-auto680):04569 FDB BLOCK-8
+24F2 17B6167C13A7 (fig-forth-auto680):04570 PLINE FDB DOCOL,TOR,LIT8
+24F8 40 (fig-forth-auto680):04571 FCB $40
+24F9 187F2344168B188B (fig-forth-auto680):04572 FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
+ 230516C1249116C1
+ 13A7
+250B 40 (fig-forth-auto680):04573 FCB $40
+250C 1662 (fig-forth-auto680):04574 FDB SEMIS
+ (fig-forth-auto680):04575 *
+ (fig-forth-auto680):04576 * ======>> 178 <<
+ (fig-forth-auto680):04577 * ( line screen --- )
+ (fig-forth-auto680):04578 * Print the line of the screen as found by (LINE), suppress trailing BLANKS.
+250E 85 (fig-forth-auto680):04579 FCB $85
+250F 2E4C494E (fig-forth-auto680):04580 FCC '.LIN' ; '.LINE'
+2513 C5 (fig-forth-auto680):04581 FCB $C5
+2514 24E9 (fig-forth-auto680):04582 FDB PLINE-9
+2516 17B624F21CD81CAA (fig-forth-auto680):04583 DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
+251E 1662 (fig-forth-auto680):04584 FDB SEMIS
+ (fig-forth-auto680):04585 *
+ (fig-forth-auto680):04586 * ======>> 179 <<
+ (fig-forth-auto680):04587 * ( n --- )
+ (fig-forth-auto680):04588 * If WARNING is 0, print "MESSAGE #n";
+ (fig-forth-auto680):04589 * otherwise, print line n relative to screen 4,
+ (fig-forth-auto680):04590 * the line number may be negative.
+ (fig-forth-auto680):04591 * Uses .LINE, but counter-adjusts to be relative to the real drive 0.
+2520 87 (fig-forth-auto680):04592 FCB $87
+2521 4D4553534147 (fig-forth-auto680):04593 FCC 'MESSAG' ; 'MESSAGE'
+2527 C5 (fig-forth-auto680):04594 FCB $C5
+2528 250E (fig-forth-auto680):04595 FDB DLINE-8
+252A 17B618D5176F1409 (fig-forth-auto680):04596 MESS FDB DOCOL,WARN,AT,ZBRAN
+2532 0019 (fig-forth-auto680):04597 FDB MESS3-*-NATWID
+2534 1A871409 (fig-forth-auto680):04598 FDB DDUP,ZBRAN
+2538 0013 (fig-forth-auto680):04599 FDB MESS3-*-NATWID
+253A 13A7 (fig-forth-auto680):04600 FDB LIT8
+253C 04 (fig-forth-auto680):04601 FCB 4
+253D 192D176F188B2324 (fig-forth-auto680):04602 FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
+ 1A01251613FA
+254B 000B (fig-forth-auto680):04603 FDB MESS4-*-NATWID
+254D 1D0B (fig-forth-auto680):04604 MESS3 FDB PDOTQ
+254F 06 (fig-forth-auto680):04605 FCB 6
+2550 657272202320 (fig-forth-auto680):04606 FCC 'err # ' ; 'err # '
+2556 28D1 (fig-forth-auto680):04607 FDB DOT
+2558 1662 (fig-forth-auto680):04608 MESS4 FDB SEMIS
+ (fig-forth-auto680):04609 *
+ (fig-forth-auto680):04610 * ======>> 180 <<
+ (fig-forth-auto680):04611 * ( n --- )
+ (fig-forth-auto680):04612 * Begin interpretation of screen (block) n.
+ (fig-forth-auto680):04613 * See also ARROW, SEMIS, and NULL.
+255A 84 (fig-forth-auto680):04614 FCB $84
+255B 4C4F41 (fig-forth-auto680):04615 FCC 'LOA' ; 'LOAD' : input:scr #
+255E C4 (fig-forth-auto680):04616 FCB $C4
+255F 2520 (fig-forth-auto680):04617 FDB MESS-10
+2561 17B61903176F167C (fig-forth-auto680):04618 LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
+ 190C176F167C183A
+ 190C1787
+2575 188B230519031787 (fig-forth-auto680):04619 FDB BSCR,STAR,BLK,STORE
+257D 211C168B190C1787 (fig-forth-auto680):04620 FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
+ 168B19031787
+258B 1662 (fig-forth-auto680):04621 FDB SEMIS
+ (fig-forth-auto680):04622 *
+ (fig-forth-auto680):04623 * ======>> 181 <<
+ (fig-forth-auto680):04624 * ( --- ) P
+ (fig-forth-auto680):04625 * Continue interpreting source code on the next screen.
+258D C3 (fig-forth-auto680):04626 FCB $C3
+258E 2D2D (fig-forth-auto680):04627 FCC '--' ; '-->'
+2590 BE (fig-forth-auto680):04628 FCB $BE
+2591 255A (fig-forth-auto680):04629 FDB LOAD-7
+2593 17B61BAB183A190C (fig-forth-auto680):04630 ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
+ 1787188B
+259F 1903176F17172334 (fig-forth-auto680):04631 FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
+ 1A011903174E
+25AD 1662 (fig-forth-auto680):04632 FDB SEMIS
+ (fig-forth-auto680):04633 PAGE
+ (fig-forth-auto680):04634 *
+ (fig-forth-auto680):04635 *
+ (fig-forth-auto680):04636 * ######>> screen 63 <<
+ (fig-forth-auto680):04637 * The next 4 subroutines are machine dependent, and are
+ (fig-forth-auto680):04638 * called by words 13 through 16 in the dictionary.
+ (fig-forth-auto680):04639 *
+ (fig-forth-auto680):04640 * ======>> 182 << code for EMIT
+ (fig-forth-auto680):04641 * ( --- ) No parameter stack effect.
+ (fig-forth-auto680):04642 * Interfaces directly with ROM. Expects output character in D (therefore, B).
+ (fig-forth-auto680):04643 * Output using rom CHROUT: redirectable to a printer on Coco.
+ (fig-forth-auto680):04644 * Outputs the character on stack (low byte of 1 bit word/cell).
+25AF 3468 (fig-forth-auto680):04645 PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.)
+25B1 1F98 (fig-forth-auto680):04646 TFR B,A ; Coco ROM wants it in A.
+25B3 5F (fig-forth-auto680):04647 CLRB
+25B4 1F9B (fig-forth-auto680):04648 TFR B,DP ; Give the ROM its direct page.
+25B6 AD9FA002 (fig-forth-auto680):04649 JSR [$A002] ; Output the character in A.
+25BA 35E8 (fig-forth-auto680):04650 PULS Y,U,DP,PC
+ (fig-forth-auto680):04651 * PEMIT STB N save B
+ (fig-forth-auto680):04652 * STX N+1 save X
+ (fig-forth-auto680):04653 * LDB ACIAC
+ (fig-forth-auto680):04654 * BITB #2 check ready bit
+ (fig-forth-auto680):04655 * BEQ PEMIT+4 if not ready for more data
+ (fig-forth-auto680):04656 * STA ACIAD
+ (fig-forth-auto680):04657 * LDX UP
+ (fig-forth-auto680):04658 * STB IOSTAT-UORIG,X
+ (fig-forth-auto680):04659 * LDB N recover B & X
+ (fig-forth-auto680):04660 * LDX N+1
+ (fig-forth-auto680):04661 * RTS only A register may change
+ (fig-forth-auto680):04662 * PEMIT JMP $E1D1 for MIKBUG
+ (fig-forth-auto680):04663 * PEMIT FCB $3F,$11,$39 for PROTO
+ (fig-forth-auto680):04664 * PEMIT JMP $D286 for Smoke Signal DOS
+ (fig-forth-auto680):04665 *
+ (fig-forth-auto680):04666 * ======>> 183 << code for KEY
+ (fig-forth-auto680):04667 * ( --- ) No parameter stack effect.
+ (fig-forth-auto680):04668 * Returns character or break flag in D, since this interfaces with Coco ROM.
+ (fig-forth-auto680):04669 * Wait for key from POLCAT on Coco.
+ (fig-forth-auto680):04670 * Returns the character code for the key pressed.
+25BC 3468 (fig-forth-auto680):04671 PKEY PSHS Y,U,DP ; Must save everything important for this one.
+25BE 86CF (fig-forth-auto680):04672 LDA #$CF ; a cursor of sorts
+25C0 5F (fig-forth-auto680):04673 CLRB
+25C1 1F9B (fig-forth-auto680):04674 TFR B,DP
+ 00 (fig-forth-auto680):04675 SETDP 0
+25C3 9E88 (fig-forth-auto680):04676 LDX <$88 ; location
+25C5 E684 (fig-forth-auto680):04677 LDB ,X ; save glyph
+25C7 A784 (fig-forth-auto680):04678 STA ,X
+25C9 AD9FA000 (fig-forth-auto680):04679 PKEYLP JSR [$A000]
+25CD B7041A (fig-forth-auto680):04680 STA $41A ; DBG!
+25D0 27F7 (fig-forth-auto680):04681 BEQ PKEYLP
+25D2 FD0418 (fig-forth-auto680):04682 STD $418 ; DBG!
+25D5 E784 (fig-forth-auto680):04683 STB ,X ; restore
+25D7 5F (fig-forth-auto680):04684 PKEYR CLRB ; for the break flag, shares code with PQTER
+25D8 8103 (fig-forth-auto680):04685 CMPA #3 ; break key
+25DA 2601 (fig-forth-auto680):04686 BNE PKEYGT
+25DC 53 (fig-forth-auto680):04687 COMB ; for the break flag
+25DD 1E89 (fig-forth-auto680):04688 PKEYGT EXG A,B ; Leave it in D for return.
+25DF 35E8 (fig-forth-auto680):04689 PULS Y,U,DP,PC ; Shares exit with PQTER
+ 7C (fig-forth-auto680):04690 SETDP IUPDP
+ (fig-forth-auto680):04691 * PKEY STB N
+ (fig-forth-auto680):04692 * STX N+1
+ (fig-forth-auto680):04693 * LDB ACIAC
+ (fig-forth-auto680):04694 * ASRB ;
+ (fig-forth-auto680):04695 * BCC PKEY+4 no incoming data yet
+ (fig-forth-auto680):04696 * LDA ACIAD
+ (fig-forth-auto680):04697 * ANDA #$7F strip parity bit
+ (fig-forth-auto680):04698 * LDX UP
+ (fig-forth-auto680):04699 * STB IOSTAT+1-UORIG,X
+ (fig-forth-auto680):04700 * LDB N
+ (fig-forth-auto680):04701 * LDX N+1
+ (fig-forth-auto680):04702 * RTS
+ (fig-forth-auto680):04703 * PKEY JMP $E1AC for MIKBUG
+ (fig-forth-auto680):04704 * PKEY FCB $3F,$14,$39 for PROTO
+ (fig-forth-auto680):04705 * PKEY JMP $D289 for Smoke Signal DOS
+ (fig-forth-auto680):04706 *
+ (fig-forth-auto680):04707 * ######>> screen 64 <<
+ (fig-forth-auto680):04708 * ======>> 184 << code for ?TERMINAL
+ (fig-forth-auto680):04709 * ( --- f ) Should change this to no stack effect.
+ (fig-forth-auto680):04710 * check break key using POLCAT
+ (fig-forth-auto680):04711 * Returns a flag to tell whether the break key was pressed or not.
+25E1 3468 (fig-forth-auto680):04712 PQTER PSHS Y,U,DP
+25E3 5F (fig-forth-auto680):04713 CLRB
+25E4 1F9B (fig-forth-auto680):04714 TFR B,DP
+25E6 AD9FA000 (fig-forth-auto680):04715 JSR [$A000] ; Look but don't wait.
+25EA 20EB (fig-forth-auto680):04716 BRA PKEYR
+ (fig-forth-auto680):04717 * PQTER LDA ACIAC Test for 'break' condition
+ (fig-forth-auto680):04718 * ANDA #$11 mask framing error bit and
+ (fig-forth-auto680):04719 * input buffer full
+ (fig-forth-auto680):04720 * BEQ PQTER2
+ (fig-forth-auto680):04721 * LDA ACIAD clear input buffer
+ (fig-forth-auto680):04722 * LDA #01
+ (fig-forth-auto680):04723 * PQTER2 RTS
+ (fig-forth-auto680):04724
+ (fig-forth-auto680):04725
+ (fig-forth-auto680):04726 PAGE
+ (fig-forth-auto680):04727 *
+ (fig-forth-auto680):04728 * ======>> 185 << code for CR
+ (fig-forth-auto680):04729 * ( --- ) No stack effect.
+ (fig-forth-auto680):04730 * Interfaces directly with ROM.
+ (fig-forth-auto680):04731 * For Coco just output a CR.
+ (fig-forth-auto680):04732 * Also subject to redirection in Coco BASIC ROM.
+25EC C60D (fig-forth-auto680):04733 PCR LDB #$0D
+25EE 20BF (fig-forth-auto680):04734 BRA PEMIT ; Just steal the code.
+ (fig-forth-auto680):04735 * PCR LDA #$D carriage return
+ (fig-forth-auto680):04736 * BSR PEMIT
+ (fig-forth-auto680):04737 * LDA #$A line feed
+ (fig-forth-auto680):04738 * BSR PEMIT
+ (fig-forth-auto680):04739 * LDA #$7F rubout
+ (fig-forth-auto680):04740 * LDX UP
+ (fig-forth-auto680):04741 * LDB XDELAY+1-UORIG,X
+ (fig-forth-auto680):04742 * PCR2 DECB ;
+ (fig-forth-auto680):04743 * BMI PQTER2 return if minus
+ (fig-forth-auto680):04744 * PSHS B ; save counter
+ (fig-forth-auto680):04745 * BSR PEMIT print RUBOUTs to delay.....
+ (fig-forth-auto680):04746 * PULS B ;
+ (fig-forth-auto680):04747 * BRA PCR2 repeat
+ (fig-forth-auto680):04748
+ (fig-forth-auto680):04749
+ (fig-forth-auto680):04750 PAGE
+ (fig-forth-auto680):04751 *
+ (fig-forth-auto680):04752 * ######>> screen 66 <<
+ (fig-forth-auto680):04753 * ======>> 187 <<
+ (fig-forth-auto680):04754 * ( ??? )
+ (fig-forth-auto680):04755 * Query the disk, I suppose.
+ (fig-forth-auto680):04756 * Not sure what the model had in mind for this stub.
+25F0 85 (fig-forth-auto680):04757 FCB $85
+25F1 3F444953 (fig-forth-auto680):04758 FCC '?DIS' ; '?DISC'
+25F5 C3 (fig-forth-auto680):04759 FCB $C3
+25F6 258D (fig-forth-auto680):04760 FDB ARROW-6
+25F8 25FA (fig-forth-auto680):04761 QDISC FDB *+NATWID
+25FA 7E1228 (fig-forth-auto680):04762 JMP NEXT
+ (fig-forth-auto680):04763 *
+ (fig-forth-auto680):04764 * ######>> screen 67 <<
+ (fig-forth-auto680):04765 * ======>> 189 <<
+ (fig-forth-auto680):04766 * ( ??? )
+ (fig-forth-auto680):04767 * Write one block of data to disk.
+ (fig-forth-auto680):04768 * Parameters unspecified in model. Stub in model.
+25FD 8B (fig-forth-auto680):04769 FCB $8B
+25FE 424C4F434B2D5752 (fig-forth-auto680):04770 FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
+ 4954
+2608 C5 (fig-forth-auto680):04771 FCB $C5
+2609 25F0 (fig-forth-auto680):04772 FDB QDISC-8
+260B 260D (fig-forth-auto680):04773 BWRITE FDB *+NATWID
+260D 7E1228 (fig-forth-auto680):04774 JMP NEXT
+ (fig-forth-auto680):04775 *
+ (fig-forth-auto680):04776 * ######>> screen 68 <<
+ (fig-forth-auto680):04777 * ======>> 190 <<
+ (fig-forth-auto680):04778 * ( ??? )
+ (fig-forth-auto680):04779 * Read one block of data from disk.
+ (fig-forth-auto680):04780 * Parameters unspecified in model. Stub in model.
+2610 8A (fig-forth-auto680):04781 FCB $8A
+2611 424C4F434B2D5245 (fig-forth-auto680):04782 FCC 'BLOCK-REA' ; 'BLOCK-READ'
+ 41
+261A C4 (fig-forth-auto680):04783 FCB $C4
+261B 25FD (fig-forth-auto680):04784 FDB BWRITE-14
+261D 261F (fig-forth-auto680):04785 BREAD FDB *+NATWID
+261F 7E1228 (fig-forth-auto680):04786 JMP NEXT
+ (fig-forth-auto680):04787 *
+ (fig-forth-auto680):04788 *The next 3 words are written to create a substitute for disc
+ (fig-forth-auto680):04789 * mass memory,located between $3210 & $3FFF in ram.
+ (fig-forth-auto680):04790 * ======>> 190.1 <<
+2622 82 (fig-forth-auto680):04791 FCB $82
+2623 4C (fig-forth-auto680):04792 FCC 'L' ; 'LO'
+2624 CF (fig-forth-auto680):04793 FCB $CF
+2625 2610 (fig-forth-auto680):04794 FDB BREAD-13
+2627 17E6 (fig-forth-auto680):04795 LO FDB DOCON
+2629 7000 (fig-forth-auto680):04796 FDB MEMEND a system dependent equate at front
+ (fig-forth-auto680):04797 *
+ (fig-forth-auto680):04798 * ======>> 190.2 <<
+262B 82 (fig-forth-auto680):04799 FCB $82
+262C 48 (fig-forth-auto680):04800 FCC 'H' ; 'HI'
+262D C9 (fig-forth-auto680):04801 FCB $C9
+262E 2622 (fig-forth-auto680):04802 FDB LO-5
+2630 17E6 (fig-forth-auto680):04803 HI FDB DOCON
+2632 7FFF (fig-forth-auto680):04804 FDB MEMTOP ( $3FFF or $7FFF in this version )
+ (fig-forth-auto680):04805 *
+ (fig-forth-auto680):04806 * ######>> screen 69 <<
+ (fig-forth-auto680):04807 * ======>> 191 <<
+ (fig-forth-auto680):04808 * ( buffer sector f --- )
+ (fig-forth-auto680):04809 * Read or Write the specified (absolute -- ignores OFFSET) sector
+ (fig-forth-auto680):04810 * from or to the specified buffer.
+ (fig-forth-auto680):04811 * A zero flag specifies write,
+ (fig-forth-auto680):04812 * non-zero specifies read.
+ (fig-forth-auto680):04813 * Sector is an unsigned integer,
+ (fig-forth-auto680):04814 * buffer is the buffer's address.
+ (fig-forth-auto680):04815 * Will need to use the CoCo ROM disk routines.
+ (fig-forth-auto680):04816 * For now, provides a virtual disk in RAM.
+2634 83 (fig-forth-auto680):04817 FCB $83
+2635 522F (fig-forth-auto680):04818 FCC 'R/' ; 'R/W'
+2637 D7 (fig-forth-auto680):04819 FCB $D7
+2638 262B (fig-forth-auto680):04820 FDB HI-5
+263A 17B6167C187F2305 (fig-forth-auto680):04821 RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
+ 262716C117422630
+ 1A321409
+264E 000D (fig-forth-auto680):04822 FDB RW2-*-NATWID
+2650 1D0B (fig-forth-auto680):04823 FDB PDOTQ
+2652 08 (fig-forth-auto680):04824 FCB 8
+2653 2052616E6765203F (fig-forth-auto680):04825 FCC ' Range ?' ; ' Range ?'
+265B 21D6 (fig-forth-auto680):04826 FDB QUIT
+265D 168B1409 (fig-forth-auto680):04827 RW2 FDB FROMR,ZBRAN
+2661 0002 (fig-forth-auto680):04828 FDB RW3-*-NATWID
+2663 1733 (fig-forth-auto680):04829 FDB SWAP
+2665 187F1583 (fig-forth-auto680):04830 RW3 FDB BBUF,CMOVE
+2669 1662 (fig-forth-auto680):04831 FDB SEMIS
+ (fig-forth-auto680):04832 *
+ (fig-forth-auto680):04833 * From BIF-6809:
+ (fig-forth-auto680):04834 * RW PSHS Y,U,DP
+ (fig-forth-auto680):04835 * LDY $C006 control table
+ (fig-forth-auto680):04836 * LDX #DROFFS+7 ; This is BIF's table of drive sizes.
+ (fig-forth-auto680):04837 * LDD 2,U
+ (fig-forth-auto680):04838 * RWD SUBD ,X++ sectors
+ (fig-forth-auto680):04839 * BHS RWD
+ (fig-forth-auto680):04840 * BVC RWR table end?
+ (fig-forth-auto680):04841 * LDD #6
+ (fig-forth-auto680):04842 * PSHU D
+ (fig-forth-auto680):04843 * JMP ERROR
+ (fig-forth-auto680):04844 * RWR ADDD ,--X back one
+ (fig-forth-auto680):04845 * PSHS X
+ (fig-forth-auto680):04846 * PSHU D
+ (fig-forth-auto680):04847 * LDD #18 sectors/track
+ (fig-forth-auto680):04848 * PSHU D
+ (fig-forth-auto680):04849 * DOCOL
+ (fig-forth-auto680):04850 * FDB SLAMOD
+ (fig-forth-auto680):04851 * FDB XMACH
+ (fig-forth-auto680):04852 * PULU D
+ (fig-forth-auto680):04853 * STB 2,Y track
+ (fig-forth-auto680):04854 * PULU D
+ (fig-forth-auto680):04855 * INCB
+ (fig-forth-auto680):04856 * STB 3,Y sector
+ (fig-forth-auto680):04857 * PULS D table entry
+ (fig-forth-auto680):04858 * SUBD #DROFFS+7
+ (fig-forth-auto680):04859 * ASRB drive #
+ (fig-forth-auto680):04860 * STB 1,Y
+ (fig-forth-auto680):04861 * LDD 4,U buffer
+ (fig-forth-auto680):04862 * STD 4,Y
+ (fig-forth-auto680):04863 * LDB #2 coco READ
+ (fig-forth-auto680):04864 * LDX ,U 0?
+ (fig-forth-auto680):04865 * BNE *+3
+ (fig-forth-auto680):04866 * INCB coco WRITE
+ (fig-forth-auto680):04867 * STB ,Y op code
+ (fig-forth-auto680):04868 * CLRA
+ (fig-forth-auto680):04869 * TFR A,DP
+ (fig-forth-auto680):04870 * JSR [$C004] ROM handles timeout
+ (fig-forth-auto680):04871 * PULS Y,U,DP if IRQ enabled
+ (fig-forth-auto680):04872 * LEAU 6,U
+ (fig-forth-auto680):04873 * LDX $C006
+ (fig-forth-auto680):04874 * LDB 6,X coco status
+ (fig-forth-auto680):04875 * BEQ RWE
+ (fig-forth-auto680):04876 * LDX <UP
+ (fig-forth-auto680):04877 * LDD #0 no disc
+ (fig-forth-auto680):04878 * STD UWARN,X
+ (fig-forth-auto680):04879 * LDD #8
+ (fig-forth-auto680):04880 * PSHU D
+ (fig-forth-auto680):04881 * JMP ERROR
+ (fig-forth-auto680):04882 * RWE NEXT
+ (fig-forth-auto680):04883 *
+ (fig-forth-auto680):04884 * ######>> screen 72 <<
+ (fig-forth-auto680):04885 * ======>> 192 <<
+ (fig-forth-auto680):04886 * ( --- ) compiling P
+ (fig-forth-auto680):04887 * ( --- adr ) interpreting
+ (fig-forth-auto680):04888 * { ' name } input
+ (fig-forth-auto680):04889 * Parse a symbol name from input and search the dictionary for it, per -FIND;
+ (fig-forth-auto680):04890 * compile the address as a literal if compiling,
+ (fig-forth-auto680):04891 * otherwise just push it.
+266B C1 (fig-forth-auto680):04892 FCB $C1 immediate
+266C A7 (fig-forth-auto680):04893 FCB $A7 ' ( tick )
+266D 2634 (fig-forth-auto680):04894 FDB RW-6
+266F 17B61FAC169E183A (fig-forth-auto680):04895 TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
+ 1B36172520E1
+267D 1662 (fig-forth-auto680):04896 FDB SEMIS
+ (fig-forth-auto680):04897 *
+ (fig-forth-auto680):04898 * ======>> 193 <<
+ (fig-forth-auto680):04899 * ( --- ) { FORGET name } input
+ (fig-forth-auto680):04900 * Parse out name of definition to FORGET to, -DFIND it,
+ (fig-forth-auto680):04901 * then lop it and everything that follows out of the dictionary.
+ (fig-forth-auto680):04902 * In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
+267F 86 (fig-forth-auto680):04903 FCB $86
+2680 464F524745 (fig-forth-auto680):04904 FCC 'FORGE' ; 'FORGET'
+2685 D4 (fig-forth-auto680):04905 FCB $D4
+2686 266B (fig-forth-auto680):04906 FDB TICK-4
+2688 17B61949176F193B (fig-forth-auto680):04907 FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
+ 176F1A0113A7
+2696 18 (fig-forth-auto680):04908 FCB $18
+2697 1B36266F174218E1 (fig-forth-auto680):04909 FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT8
+ 176F1A1A13A7
+26A5 15 (fig-forth-auto680):04910 FCB $15
+26A6 1B361742183A1899 (fig-forth-auto680):04911 FDB QERR,DUP,ZERO,PORIG,GREAT,LIT8
+ 1A3213A7
+26B2 15 (fig-forth-auto680):04912 FCB $15
+26B3 1B3617421AFA18EA (fig-forth-auto680):04913 FDB QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
+ 17871ADD176F193B
+ 176F1787
+26C7 1662 (fig-forth-auto680):04914 FDB SEMIS
+ (fig-forth-auto680):04915 *
+ (fig-forth-auto680):04916 * ######>> screen 73 <<
+ (fig-forth-auto680):04917 * ======>> 194 <<
+ (fig-forth-auto680):04918 * ( adr --- ) C
+ (fig-forth-auto680):04919 * Calculate a back reference from HERE and compile it.
+26C9 84 (fig-forth-auto680):04920 FCB $84
+26CA 424143 (fig-forth-auto680):04921 FCC 'BAC' ; 'BACK'
+26CD CB (fig-forth-auto680):04922 FCB $CB
+26CE 267F (fig-forth-auto680):04923 FDB FORGET-9
+26D0 17B619C41A0119E0 (fig-forth-auto680):04924 BACK FDB DOCOL,HERE,SUB,COMMA
+26D8 1662 (fig-forth-auto680):04925 FDB SEMIS
+ (fig-forth-auto680):04926 *
+ (fig-forth-auto680):04927 * ======>> 195 <<
+ (fig-forth-auto680):04928 * ( --- ) runtime
+ (fig-forth-auto680):04929 * typical use: BEGIN code-loop test UNTIL
+ (fig-forth-auto680):04930 * typical use: BEGIN code-loop AGAIN
+ (fig-forth-auto680):04931 * typical use: BEGIN code-loop test WHILE code-true REPEAT
+ (fig-forth-auto680):04932 * ( --- adr n ) compile time P,C
+ (fig-forth-auto680):04933 * Push HERE for BACK reference for general (non-counting) loops,
+ (fig-forth-auto680):04934 * with BEGIN construct flag.
+ (fig-forth-auto680):04935 * A better flag: $4245 (ASCII for 'BE').
+26DA C5 (fig-forth-auto680):04936 FCB $C5
+26DB 42454749 (fig-forth-auto680):04937 FCC 'BEGI' ; 'BEGIN'
+26DF CE (fig-forth-auto680):04938 FCB $CE
+26E0 26C9 (fig-forth-auto680):04939 FDB BACK-7
+26E2 17B61B5019C41842 (fig-forth-auto680):04940 BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
+26EA 1662 (fig-forth-auto680):04941 FDB SEMIS
+ (fig-forth-auto680):04942 *
+ (fig-forth-auto680):04943 * ======>> 196 <<
+ (fig-forth-auto680):04944 * ( --- ) runtime
+ (fig-forth-auto680):04945 * typical use: test IF code-true ELSE code-false ENDIF
+ (fig-forth-auto680):04946 * ENDIF is just a sort of intersection piece,
+ (fig-forth-auto680):04947 * marking where execution resumes after both branches.
+ (fig-forth-auto680):04948 * ( adr n --- ) compile time
+ (fig-forth-auto680):04949 * Check the mark and resolve the IF.
+ (fig-forth-auto680):04950 * A better flag: $4846 (ASCII for 'IF').
+26EC C5 (fig-forth-auto680):04951 FCB $C5
+26ED 454E4449 (fig-forth-auto680):04952 FCC 'ENDI' ; 'ENDIF'
+26F1 C6 (fig-forth-auto680):04953 FCB $C6
+26F2 26DA (fig-forth-auto680):04954 FDB BEGIN-8
+26F4 17B61B50184A1B7D (fig-forth-auto680):04955 ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
+ 19C4
+26FE 17171A0117331787 (fig-forth-auto680):04956 FDB OVER,SUB,SWAP,STORE
+2706 1662 (fig-forth-auto680):04957 FDB SEMIS
+ (fig-forth-auto680):04958 *
+ (fig-forth-auto680):04959 * ======>> 197 <<
+ (fig-forth-auto680):04960 * ( --- ) runtime
+ (fig-forth-auto680):04961 * typical use: test IF code-true ELSE code-false ENDIF
+ (fig-forth-auto680):04962 * ( adr n --- )
+ (fig-forth-auto680):04963 * Alias for ENDIF .
+2708 C4 (fig-forth-auto680):04964 FCB $C4
+2709 544845 (fig-forth-auto680):04965 FCC 'THE' ; 'THEN'
+270C CE (fig-forth-auto680):04966 FCB $CE
+270D 26EC (fig-forth-auto680):04967 FDB ENDIF-8
+270F 17B626F4 (fig-forth-auto680):04968 THEN FDB DOCOL,ENDIF
+2713 1662 (fig-forth-auto680):04969 FDB SEMIS
+ (fig-forth-auto680):04970 *
+ (fig-forth-auto680):04971 * ======>> 198 <<
+ (fig-forth-auto680):04972 * ( limit index --- ) runtime
+ (fig-forth-auto680):04973 * typical use: DO code-loop LOOP
+ (fig-forth-auto680):04974 * typical use: DO code-loop increment +LOOP
+ (fig-forth-auto680):04975 * Counted loop, index is initial value of index.
+ (fig-forth-auto680):04976 * Will loop until index equals (positive going)
+ (fig-forth-auto680):04977 * or passes (negative going) limit.
+ (fig-forth-auto680):04978 * ( --- adr n ) compile time P,C
+ (fig-forth-auto680):04979 * Compile (DO), push HERE for BACK reference,
+ (fig-forth-auto680):04980 * and push DO control construct flag.
+ (fig-forth-auto680):04981 * A better flag: $444F (ASCII for 'DO').
+2715 C2 (fig-forth-auto680):04982 FCB $C2
+2716 44 (fig-forth-auto680):04983 FCC 'D' ; 'DO'
+2717 CF (fig-forth-auto680):04984 FCB $CF
+2718 2708 (fig-forth-auto680):04985 FDB THEN-7
+271A 17B61BC4145319C4 (fig-forth-auto680):04986 DO FDB DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
+ 1852
+2724 1662 (fig-forth-auto680):04987 FDB SEMIS
+ (fig-forth-auto680):04988 *
+ (fig-forth-auto680):04989 * ======>> 199 <<
+ (fig-forth-auto680):04990 * ( --- ) runtime
+ (fig-forth-auto680):04991 * typical use: DO code-loop LOOP
+ (fig-forth-auto680):04992 * Increments the index by one and branches back to beginning of loop.
+ (fig-forth-auto680):04993 * Will loop until index equals limit.
+ (fig-forth-auto680):04994 * ( adr n --- ) compile time P,C
+ (fig-forth-auto680):04995 * Check the mark and compile (LOOP), fill in BACK reference.
+ (fig-forth-auto680):04996 * A better flag: $444F (ASCII for 'DO').
+2726 C4 (fig-forth-auto680):04997 FCB $C4
+2727 4C4F4F (fig-forth-auto680):04998 FCC 'LOO' ; 'LOOP'
+272A D0 (fig-forth-auto680):04999 FCB $D0
+272B 2715 (fig-forth-auto680):05000 FDB DO-5
+272D 17B618521B7D1BC4 (fig-forth-auto680):05001 LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
+ 141D26D0
+2739 1662 (fig-forth-auto680):05002 FDB SEMIS
+ (fig-forth-auto680):05003 *
+ (fig-forth-auto680):05004 * ======>> 200 <<
+ (fig-forth-auto680):05005 * ( n --- ) runtime
+ (fig-forth-auto680):05006 * typical use: DO code-loop increment +LOOP
+ (fig-forth-auto680):05007 * Increments the index by n and branches back to beginning of loop.
+ (fig-forth-auto680):05008 * Will loop until index equals (positive going)
+ (fig-forth-auto680):05009 * or passes (negative going) limit.
+ (fig-forth-auto680):05010 * ( adr n --- ) compile time P,C
+ (fig-forth-auto680):05011 * Check the mark and compile (+LOOP), fill in BACK reference.
+ (fig-forth-auto680):05012 * A better flag: $444F (ASCII for 'DO').
+273B C5 (fig-forth-auto680):05013 FCB $C5
+273C 2B4C4F4F (fig-forth-auto680):05014 FCC '+LOO' ; '+LOOP'
+2740 D0 (fig-forth-auto680):05015 FCB $D0
+2741 2726 (fig-forth-auto680):05016 FDB LOOP-7
+2743 17B618521B7D1BC4 (fig-forth-auto680):05017 PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
+ 143C26D0
+274F 1662 (fig-forth-auto680):05018 FDB SEMIS
+ (fig-forth-auto680):05019 *
+ (fig-forth-auto680):05020 * ======>> 201 <<
+ (fig-forth-auto680):05021 * ( n --- ) runtime
+ (fig-forth-auto680):05022 * typical use: BEGIN code-loop test UNTIL
+ (fig-forth-auto680):05023 * Will loop until UNTIL tests true.
+ (fig-forth-auto680):05024 * ( adr n --- ) compile time P,C
+ (fig-forth-auto680):05025 * Check the mark and compile (0BRANCH), fill in BACK reference.
+ (fig-forth-auto680):05026 * A better flag: $4245 (ASCII for 'BE').
+2751 C5 (fig-forth-auto680):05027 FCB $C5
+2752 554E5449 (fig-forth-auto680):05028 FCC 'UNTI' ; 'UNTIL' : ( same as END )
+2756 CC (fig-forth-auto680):05029 FCB $CC
+2757 273B (fig-forth-auto680):05030 FDB PLOOP-8
+2759 17B618421B7D1BC4 (fig-forth-auto680):05031 UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
+ 140926D0
+2765 1662 (fig-forth-auto680):05032 FDB SEMIS
+ (fig-forth-auto680):05033 *
+ (fig-forth-auto680):05034 * ######>> screen 74 <<
+ (fig-forth-auto680):05035 * ======>> 202 <<
+ (fig-forth-auto680):05036 * ( n --- ) runtime
+ (fig-forth-auto680):05037 * typical use: BEGIN code-loop test END
+ (fig-forth-auto680):05038 * ( adr n --- )
+ (fig-forth-auto680):05039 * Alias for UNTIL .
+2767 C3 (fig-forth-auto680):05040 FCB $C3
+2768 454E (fig-forth-auto680):05041 FCC 'EN' ; 'END'
+276A C4 (fig-forth-auto680):05042 FCB $C4
+276B 2751 (fig-forth-auto680):05043 FDB UNTIL-8
+276D 17B62759 (fig-forth-auto680):05044 END FDB DOCOL,UNTIL
+2771 1662 (fig-forth-auto680):05045 FDB SEMIS
+ (fig-forth-auto680):05046 *
+ (fig-forth-auto680):05047 * ======>> 203 <<
+ (fig-forth-auto680):05048 * ( --- ) runtime
+ (fig-forth-auto680):05049 * typical use: BEGIN code-loop AGAIN
+ (fig-forth-auto680):05050 * Will loop forever
+ (fig-forth-auto680):05051 * (or until something uses R> DROP to force the current definition to die,
+ (fig-forth-auto680):05052 * or perhaps ABORT or ERROR or some such other drastic means stops things).
+ (fig-forth-auto680):05053 * ( adr n --- ) compile time P,C
+ (fig-forth-auto680):05054 * Check the mark and compile (0BRANCH), fill in BACK reference.
+ (fig-forth-auto680):05055 * A better flag: $4245 (ASCII for 'BE').
+2773 C5 (fig-forth-auto680):05056 FCB $C5
+2774 41474149 (fig-forth-auto680):05057 FCC 'AGAI' ; 'AGAIN'
+2778 CE (fig-forth-auto680):05058 FCB $CE
+2779 2767 (fig-forth-auto680):05059 FDB END-6
+277B 17B618421B7D1BC4 (fig-forth-auto680):05060 AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
+ 13FA26D0
+2787 1662 (fig-forth-auto680):05061 FDB SEMIS
+ (fig-forth-auto680):05062 *
+ (fig-forth-auto680):05063 * ======>> 204 <<
+ (fig-forth-auto680):05064 * ( --- ) runtime
+ (fig-forth-auto680):05065 * typical use: BEGIN code-loop test WHILE code-true REPEAT
+ (fig-forth-auto680):05066 * Will loop until WHILE tests false, skipping code-true on end.
+ (fig-forth-auto680):05067 * REPEAT marks where execution resumes after the WHILE find a false flag.
+ (fig-forth-auto680):05068 * ( aadr1 n1 adr2 n2 --- ) compile time P,C
+ (fig-forth-auto680):05069 * Check the marks for WHILE and BEGIN,
+ (fig-forth-auto680):05070 * compile BRANCH and BACK fill adr1 reference,
+ (fig-forth-auto680):05071 * FILL-IN 0BRANCH reference at adr2.
+ (fig-forth-auto680):05072 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+2789 C6 (fig-forth-auto680):05073 FCB $C6
+278A 5245504541 (fig-forth-auto680):05074 FCC 'REPEA' ; 'REPEAT'
+278F D4 (fig-forth-auto680):05075 FCB $D4
+2790 2773 (fig-forth-auto680):05076 FDB AGAIN-8
+2792 17B6167C167C277B (fig-forth-auto680):05077 REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
+ 168B168B
+279E 184A1A0126F4 (fig-forth-auto680):05078 FDB TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
+27A4 1662 (fig-forth-auto680):05079 FDB SEMIS
+ (fig-forth-auto680):05080 *
+ (fig-forth-auto680):05081 * ======>> 205 <<
+ (fig-forth-auto680):05082 * ( n --- ) runtime
+ (fig-forth-auto680):05083 * typical use: test IF code-true ELSE code-false ENDIF
+ (fig-forth-auto680):05084 * Will pass execution to the true part on a true flag
+ (fig-forth-auto680):05085 * and to the false part on a false flag.
+ (fig-forth-auto680):05086 * ( --- adr n ) compile time P,C
+ (fig-forth-auto680):05087 * Compile a 0BRANCH and dummy offset
+ (fig-forth-auto680):05088 * and push IF reference to fill in and
+ (fig-forth-auto680):05089 * IF control construct flag.
+ (fig-forth-auto680):05090 * A better flag: $4946 (ASCII for 'IF').
+27A6 C2 (fig-forth-auto680):05091 FCB $C2
+27A7 49 (fig-forth-auto680):05092 FCC 'I' ; 'IF'
+27A8 C6 (fig-forth-auto680):05093 FCB $C6
+27A9 2789 (fig-forth-auto680):05094 FDB REPEAT-9
+27AB 17B61BC4140919C4 (fig-forth-auto680):05095 IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
+ 183A19E0184A
+27B9 1662 (fig-forth-auto680):05096 FDB SEMIS
+ (fig-forth-auto680):05097 *
+ (fig-forth-auto680):05098 * ======>> 206 <<
+ (fig-forth-auto680):05099 * ( --- ) runtime
+ (fig-forth-auto680):05100 * typical use: test IF code-true ELSE code-false ENDIF
+ (fig-forth-auto680):05101 * ELSE is just a sort of intersection piece,
+ (fig-forth-auto680):05102 * marking where execution resumes on a false branch.
+ (fig-forth-auto680):05103 * ( adr1 n --- adr2 n ) compile time P,C
+ (fig-forth-auto680):05104 * Check the marks,
+ (fig-forth-auto680):05105 * compile BRANCH with dummy offset,
+ (fig-forth-auto680):05106 * resolve IF reference,
+ (fig-forth-auto680):05107 * and leave reference to BRANCH for ELSE.
+ (fig-forth-auto680):05108 * A better flag: $4946 (ASCII for 'IF').
+27BB C4 (fig-forth-auto680):05109 FCB $C4
+27BC 454C53 (fig-forth-auto680):05110 FCC 'ELS' ; 'ELSE'
+27BF C5 (fig-forth-auto680):05111 FCB $C5
+27C0 27A6 (fig-forth-auto680):05112 FDB IF-5
+27C2 17B6184A1B7D1BC4 (fig-forth-auto680):05113 ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
+ 13FA19C4
+27CE 183A19E01733184A (fig-forth-auto680):05114 FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
+ 26F4184A
+27DA 1662 (fig-forth-auto680):05115 FDB SEMIS
+ (fig-forth-auto680):05116 *
+ (fig-forth-auto680):05117 * ======>> 207 <<
+ (fig-forth-auto680):05118 * ( n --- ) runtime
+ (fig-forth-auto680):05119 * typical use: BEGIN code-loop test WHILE code-true REPEAT
+ (fig-forth-auto680):05120 * Will loop until WHILE tests false, skipping code-true on end.
+ (fig-forth-auto680):05121 * ( --- adr n ) compile time P,C
+ (fig-forth-auto680):05122 * Compile 0BRANCH with dummy offset (using IF),
+ (fig-forth-auto680):05123 * push WHILE reference.
+ (fig-forth-auto680):05124 * BEGIN flag will sit underneath this.
+ (fig-forth-auto680):05125 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+27DC C5 (fig-forth-auto680):05126 FCB $C5
+27DD 5748494C (fig-forth-auto680):05127 FCC 'WHIL' ; 'WHILE'
+27E1 C5 (fig-forth-auto680):05128 FCB $C5
+27E2 27BB (fig-forth-auto680):05129 FDB ELSE-7
+27E4 17B627AB19B5 (fig-forth-auto680):05130 WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
+27EA 1662 (fig-forth-auto680):05131 FDB SEMIS
+ (fig-forth-auto680):05132 *
+ (fig-forth-auto680):05133 * ######>> screen 75 <<
+ (fig-forth-auto680):05134 * ======>> 208 <<
+ (fig-forth-auto680):05135 * ( count --- )
+ (fig-forth-auto680):05136 * EMIT count spaces, for non-zero, non-negative counts.
+27EC 86 (fig-forth-auto680):05137 FCB $86
+27ED 5350414345 (fig-forth-auto680):05138 FCC 'SPACE' ; 'SPACES'
+27F2 D3 (fig-forth-auto680):05139 FCB $D3
+27F3 27DC (fig-forth-auto680):05140 FDB WHILE-8
+27F5 17B6183A1A741A87 (fig-forth-auto680):05141 SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
+ 1409
+27FF 000A (fig-forth-auto680):05142 FDB SPACE3-*-NATWID
+2801 183A1453 (fig-forth-auto680):05143 FDB ZERO,XDO
+2805 1A54141D (fig-forth-auto680):05144 SPACE2 FDB SPACE,XLOOP
+2809 FFFA (fig-forth-auto680):05145 FDB SPACE2-*-NATWID
+280B 1662 (fig-forth-auto680):05146 SPACE3 FDB SEMIS
+ (fig-forth-auto680):05147 *
+ (fig-forth-auto680):05148 * ======>> 209 <<
+ (fig-forth-auto680):05149 * ( --- )
+ (fig-forth-auto680):05150 * Initialize HLD for converting a double integer.
+ (fig-forth-auto680):05151 * Stores the PAD address in HLD.
+280D 82 (fig-forth-auto680):05152 FCB $82
+280E 3C (fig-forth-auto680):05153 FCC '<' ; '<#'
+280F A3 (fig-forth-auto680):05154 FCB $A3
+2810 27EC (fig-forth-auto680):05155 FDB SPACES-9
+2812 17B61EA919911787 (fig-forth-auto680):05156 BDIGS FDB DOCOL,PAD,HLD,STORE
+281A 1662 (fig-forth-auto680):05157 FDB SEMIS
+ (fig-forth-auto680):05158 *
+ (fig-forth-auto680):05159 * ======>> 210 <<
+ (fig-forth-auto680):05160 * ( d --- string length )
+ (fig-forth-auto680):05161 * Terminate numeric conversion,
+ (fig-forth-auto680):05162 * drop the number being converted,
+ (fig-forth-auto680):05163 * leave the address of the conversion string and the length, ready for TYPE.
+281C 82 (fig-forth-auto680):05164 FCB $82
+281D 23 (fig-forth-auto680):05165 FCC '#' ; '#>'
+281E BE (fig-forth-auto680):05166 FCB $BE
+281F 280D (fig-forth-auto680):05167 FDB BDIGS-5
+2821 17B6172517251991 (fig-forth-auto680):05168 EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
+ 176F1EA917171A01
+2831 1662 (fig-forth-auto680):05169 FDB SEMIS
+ (fig-forth-auto680):05170 *
+ (fig-forth-auto680):05171 * ======>> 211 <<
+ (fig-forth-auto680):05172 * ( n d --- d )
+ (fig-forth-auto680):05173 * Put sign of n (as a flag) at the head of the conversion string.
+ (fig-forth-auto680):05174 * Drop the sign flag.
+2833 84 (fig-forth-auto680):05175 FCB $84
+2834 534947 (fig-forth-auto680):05176 FCC 'SIG' ; 'SIGN'
+2837 CE (fig-forth-auto680):05177 FCB $CE
+2838 281C (fig-forth-auto680):05178 FDB EDIGS-5
+283A 17B61A4016B01409 (fig-forth-auto680):05179 SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
+2842 0005 (fig-forth-auto680):05180 FDB SIGN2-*-NATWID
+2844 13A7 (fig-forth-auto680):05181 FDB LIT8
+2846 2D (fig-forth-auto680):05182 FCC "-"
+2847 1E91 (fig-forth-auto680):05183 FDB HOLD
+2849 1662 (fig-forth-auto680):05184 SIGN2 FDB SEMIS
+ (fig-forth-auto680):05185 *
+ (fig-forth-auto680):05186 * ======>> 212 <<
+ (fig-forth-auto680):05187 * ( d --- d/base )
+ (fig-forth-auto680):05188 * Generate next most significant digit in the conversion BASE,
+ (fig-forth-auto680):05189 * putting the digit at the head of the conversion string.
+284B 81 (fig-forth-auto680):05190 FCB $81 #
+284C A3 (fig-forth-auto680):05191 FCB $A3
+284D 2833 (fig-forth-auto680):05192 FDB SIGN-7
+284F 17B61960176F2367 (fig-forth-auto680):05193 DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
+ 1A4013A7
+285B 09 (fig-forth-auto680):05194 FCB 9
+285C 17171A1A1409 (fig-forth-auto680):05195 FDB OVER,LESS,ZBRAN
+2862 0005 (fig-forth-auto680):05196 FDB DIG2-*-NATWID
+2864 13A7 (fig-forth-auto680):05197 FDB LIT8
+2866 07 (fig-forth-auto680):05198 FCB 7
+2867 16C1 (fig-forth-auto680):05199 FDB PLUS
+2869 13A7 (fig-forth-auto680):05200 DIG2 FDB LIT8
+286B 30 (fig-forth-auto680):05201 FCC "0" ascii zero
+286C 16C11E91 (fig-forth-auto680):05202 FDB PLUS,HOLD
+2870 1662 (fig-forth-auto680):05203 FDB SEMIS
+ (fig-forth-auto680):05204 *
+ (fig-forth-auto680):05205 * ======>> 213 <<
+ (fig-forth-auto680):05206 * ( d --- dzero )
+ (fig-forth-auto680):05207 * Convert d to a numeric string using # until the result is zero.
+ (fig-forth-auto680):05208 * Leave the double result on the stack for #> to drop.
+2872 82 (fig-forth-auto680):05209 FCB $82
+2873 23 (fig-forth-auto680):05210 FCC '#' ; '#S'
+2874 D3 (fig-forth-auto680):05211 FCB $D3
+2875 284B (fig-forth-auto680):05212 FDB DIG-4
+2877 17B6 (fig-forth-auto680):05213 DIGS FDB DOCOL
+2879 284F171717171619 (fig-forth-auto680):05214 DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
+ 169E1409
+2885 FFF2 (fig-forth-auto680):05215 FDB DIGS2-*-NATWID
+2887 1662 (fig-forth-auto680):05216 FDB SEMIS
+ (fig-forth-auto680):05217 *
+ (fig-forth-auto680):05218 * ######>> screen 76 <<
+ (fig-forth-auto680):05219 * ======>> 214 <<
+ (fig-forth-auto680):05220 * ( n width --- )
+ (fig-forth-auto680):05221 * Print n on the output device in the current conversion base,
+ (fig-forth-auto680):05222 * with sign,
+ (fig-forth-auto680):05223 * right aligned in a field at least width wide.
+2889 82 (fig-forth-auto680):05224 FCB $82
+288A 2E (fig-forth-auto680):05225 FCC '.' ; '.R'
+288B D2 (fig-forth-auto680):05226 FCB $D2
+288C 2872 (fig-forth-auto680):05227 FDB DIGS-5
+288E 17B6167C22F7168B (fig-forth-auto680):05228 DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
+ 28A0
+2898 1662 (fig-forth-auto680):05229 FDB SEMIS
+ (fig-forth-auto680):05230 *
+ (fig-forth-auto680):05231 * ======>> 215 <<
+ (fig-forth-auto680):05232 * ( d width --- )
+ (fig-forth-auto680):05233 * Print d on the output device in the current conversion base,
+ (fig-forth-auto680):05234 * with sign,
+ (fig-forth-auto680):05235 * right aligned in a field at least width wide.
+289A 83 (fig-forth-auto680):05236 FCB $83
+289B 442E (fig-forth-auto680):05237 FCC 'D.' ; 'D.R'
+289D D2 (fig-forth-auto680):05238 FCB $D2
+289E 2889 (fig-forth-auto680):05239 FDB DOTR-5
+28A0 17B6167C17331717 (fig-forth-auto680):05240 DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
+ 239828122877283A
+28B0 2821168B17171A01 (fig-forth-auto680):05241 FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
+ 27F51CAA
+28BC 1662 (fig-forth-auto680):05242 FDB SEMIS
+ (fig-forth-auto680):05243 *
+ (fig-forth-auto680):05244 * ======>> 216 <<
+ (fig-forth-auto680):05245 * D. ( d --- )
+ (fig-forth-auto680):05246 * Print d on the output device in the current conversion base,
+ (fig-forth-auto680):05247 * with sign,
+ (fig-forth-auto680):05248 * in free format with trailing space.
+28BE 82 (fig-forth-auto680):05249 FCB $82
+28BF 44 (fig-forth-auto680):05250 FCC 'D' ; 'D.'
+28C0 AE (fig-forth-auto680):05251 FCB $AE
+28C1 289A (fig-forth-auto680):05252 FDB DDOTR-6
+28C3 17B6183A28A01A54 (fig-forth-auto680):05253 DDOT FDB DOCOL,ZERO,DDOTR,SPACE
+28CB 1662 (fig-forth-auto680):05254 FDB SEMIS
+ (fig-forth-auto680):05255 *
+ (fig-forth-auto680):05256 * ======>> 217 <<
+ (fig-forth-auto680):05257 * ( n --- )
+ (fig-forth-auto680):05258 * Print n on the output device in the current conversion base,
+ (fig-forth-auto680):05259 * with sign,
+ (fig-forth-auto680):05260 * in free format with trailing space.
+28CD 81 (fig-forth-auto680):05261 FCB $81 .
+28CE AE (fig-forth-auto680):05262 FCB $AE
+28CF 28BE (fig-forth-auto680):05263 FDB DDOT-5
+28D1 17B622F728C3 (fig-forth-auto680):05264 DOT FDB DOCOL,STOD,DDOT
+28D7 1662 (fig-forth-auto680):05265 FDB SEMIS
+ (fig-forth-auto680):05266 *
+ (fig-forth-auto680):05267 * ======>> 218 <<
+ (fig-forth-auto680):05268 * ( adr --- )
+ (fig-forth-auto680):05269 * Print signed word at adr, per DOT.
+28D9 81 (fig-forth-auto680):05270 FCB $81 ?
+28DA BF (fig-forth-auto680):05271 FCB $BF
+28DB 28CD (fig-forth-auto680):05272 FDB DOT-4
+28DD 17B6176F28D1 (fig-forth-auto680):05273 QUEST FDB DOCOL,AT,DOT
+28E3 1662 (fig-forth-auto680):05274 FDB SEMIS
+ (fig-forth-auto680):05275 *
+ (fig-forth-auto680):05276 * ######>> screen 77 <<
+ (fig-forth-auto680):05277 * ======>> 219 <<
+ (fig-forth-auto680):05278 * ( n --- )
+ (fig-forth-auto680):05279 * Print out screen n as a field of ASCII,
+ (fig-forth-auto680):05280 * with line numbers in decimal.
+28E5 84 (fig-forth-auto680):05281 FCB $84
+28E6 4C4953 (fig-forth-auto680):05282 FCC 'LIS' ; 'LIST'
+28E9 D4 (fig-forth-auto680):05283 FCB $D4
+28EA 28D9 (fig-forth-auto680):05284 FDB QUEST-4
+28EC 17B61C2015761742 (fig-forth-auto680):05285 LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
+ 192017871D0B
+28FA 06 (fig-forth-auto680):05286 FCB 6
+28FB 534352202320 (fig-forth-auto680):05287 FCC "SCR # "
+2901 28D113A7 (fig-forth-auto680):05288 FDB DOT,LIT8
+2905 10 (fig-forth-auto680):05289 FCB $10
+2906 183A1453 (fig-forth-auto680):05290 FDB ZERO,XDO
+290A 157614651852 (fig-forth-auto680):05291 LIST2 FDB CR,I,THREE
+2910 288E1A5414651920 (fig-forth-auto680):05292 FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
+ 176F2516141D
+291E FFEA (fig-forth-auto680):05293 FDB LIST2-*-NATWID
+2920 1576 (fig-forth-auto680):05294 FDB CR
+2922 1662 (fig-forth-auto680):05295 FDB SEMIS
+ (fig-forth-auto680):05296 *
+ (fig-forth-auto680):05297 * ======>> 220 <<
+ (fig-forth-auto680):05298 * ( start end --- )
+ (fig-forth-auto680):05299 * Print comment lines (line 0, and line 1 if C/L < 41) of screens
+ (fig-forth-auto680):05300 * from start to end.
+2924 85 (fig-forth-auto680):05301 FCB $85
+2925 494E4445 (fig-forth-auto680):05302 FCC 'INDE' ; 'INDEX'
+2929 D8 (fig-forth-auto680):05303 FCB $D8
+292A 28E5 (fig-forth-auto680):05304 FDB LIST-7
+292C 17B6157619A81733 (fig-forth-auto680):05305 INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
+ 1453
+2936 157614651852 (fig-forth-auto680):05306 INDEX2 FDB CR,I,THREE
+293C 288E1A54183A1465 (fig-forth-auto680):05307 FDB DOTR,SPACE,ZERO,I,DLINE
+ 2516
+2946 15691409 (fig-forth-auto680):05308 FDB QTERM,ZBRAN
+294A 0002 (fig-forth-auto680):05309 FDB INDEX3-*-NATWID
+294C 1670 (fig-forth-auto680):05310 FDB LEAVE
+294E 141D (fig-forth-auto680):05311 INDEX3 FDB XLOOP
+2950 FFE4 (fig-forth-auto680):05312 FDB INDEX2-*-NATWID
+2952 1662 (fig-forth-auto680):05313 FDB SEMIS
+ (fig-forth-auto680):05314 *
+ (fig-forth-auto680):05315 * ======>> 221 <<
+ (fig-forth-auto680):05316 * ( n --- )
+ (fig-forth-auto680):05317 * List a printer page full of screens.
+ (fig-forth-auto680):05318 * Line and screen number are in current base.
+2954 85 (fig-forth-auto680):05319 FCB $85
+2955 54524941 (fig-forth-auto680):05320 FCC 'TRIA' ; 'TRIAD'
+2959 C4 (fig-forth-auto680):05321 FCB $C4
+295A 2924 (fig-forth-auto680):05322 FDB INDEX-8
+295C 17B6185223241852 (fig-forth-auto680):05323 TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
+ 2305
+2966 1852171716C11733 (fig-forth-auto680):05324 FDB THREE,OVER,PLUS,SWAP,XDO
+ 1453
+2970 15761465 (fig-forth-auto680):05325 TRIAD2 FDB CR,I
+2974 28EC15691409 (fig-forth-auto680):05326 FDB LIST,QTERM,ZBRAN
+297A 0002 (fig-forth-auto680):05327 FDB TRIAD3-*-NATWID
+297C 1670 (fig-forth-auto680):05328 FDB LEAVE
+297E 141D (fig-forth-auto680):05329 TRIAD3 FDB XLOOP
+2980 FFEE (fig-forth-auto680):05330 FDB TRIAD2-*-NATWID
+2982 157613A7 (fig-forth-auto680):05331 FDB CR,LIT8
+2986 0F (fig-forth-auto680):05332 FCB $0F
+2987 252A1576 (fig-forth-auto680):05333 FDB MESS,CR
+298B 1662 (fig-forth-auto680):05334 FDB SEMIS
+ (fig-forth-auto680):05335 *
+ (fig-forth-auto680):05336 * ######>> screen 78 <<
+ (fig-forth-auto680):05337 * ======>> 222 <<
+ (fig-forth-auto680):05338 * ( --- )
+ (fig-forth-auto680):05339 * Alphabetically list the definitions in the current vocabulary.
+298D 85 (fig-forth-auto680):05340 FCB $85
+298E 564C4953 (fig-forth-auto680):05341 FCC 'VLIS' ; 'VLIST'
+2992 D4 (fig-forth-auto680):05342 FCB $D4
+2993 2954 (fig-forth-auto680):05343 FDB TRIAD-8
+2995 17B613A7 (fig-forth-auto680):05344 VLIST FDB DOCOL,LIT8
+2999 80 (fig-forth-auto680):05345 FCB $80
+299A 19161787193B176F (fig-forth-auto680):05346 FDB OUT,STORE,CONTXT,AT,AT
+ 176F
+29A4 1916176F199F176F (fig-forth-auto680):05347 VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
+ 13A7
+29AE 20 (fig-forth-auto680):05348 FCB 32
+29AF 1A011A321409 (fig-forth-auto680):05349 FDB SUB,GREAT,ZBRAN
+29B5 0008 (fig-forth-auto680):05350 FDB VLIST2-*-NATWID
+29B7 1576183A19161787 (fig-forth-auto680):05351 FDB CR,ZERO,OUT,STORE
+29BF 1742202F1A541A54 (fig-forth-auto680):05352 VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
+ 1B0F1ADD176F
+29CD 1742169E15691619 (fig-forth-auto680):05353 FDB DUP,ZEQU,QTERM,OR,ZBRAN
+ 1409
+29D7 FFCB (fig-forth-auto680):05354 FDB VLIST1-*-NATWID
+29D9 1725 (fig-forth-auto680):05355 FDB DROP
+29DB 1662 (fig-forth-auto680):05356 FDB SEMIS
+ (fig-forth-auto680):05357 *
+ (fig-forth-auto680):05358 * ======>> XX <<
+ (fig-forth-auto680):05359 * ( --- )
+ (fig-forth-auto680):05360 * Mostly for place holding.
+29DD 84 (fig-forth-auto680):05361 FCB $84
+29DE 4E4F4F (fig-forth-auto680):05362 FCC 'NOO' ; 'NOOP'
+29E1 D0 (fig-forth-auto680):05363 FCB $D0
+29E2 298D (fig-forth-auto680):05364 FDB VLIST-8
+29E4 1228 (fig-forth-auto680):05365 NOOP FDB NEXT a useful no-op
+29E6 0000000000000000 (fig-forth-auto680):05366 ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
+ 0000000000000000
+ (fig-forth-auto680):05367
+ (fig-forth-auto680):05368 PAGE
+ (fig-forth-auto680):05369 * These things, up through the lable 'REND', are overwritten
+ (fig-forth-auto680):05370 * at time of cold load and should have the same contents
+ (fig-forth-auto680):05371 * as shown here:
+ (fig-forth-auto680):05372 *
+ (fig-forth-auto680):05373 * This can be moved whereever the bottom of the
+ (fig-forth-auto680):05374 * user's dictionary is going to be put.
+ (fig-forth-auto680):05375 *
+29F6 C5 (fig-forth-auto680):05376 FCB $C5 immediate
+29F7 464F5254 (fig-forth-auto680):05377 FCC 'FORT' ; 'FORTH'
+29FB C8 (fig-forth-auto680):05378 FCB $C8
+29FC 29DD (fig-forth-auto680):05379 FDB NOOP-7
+29FE 1C8121A081A02A26 (fig-forth-auto680):05380 FORTH FDB DODOES,DOVOC,$81A0,TASK-7
+2A06 0000 (fig-forth-auto680):05381 FDB 0
+ (fig-forth-auto680):05382 *
+2A08 28432920466F7274 (fig-forth-auto680):05383 FCC "(C) Forth Interest Group, 1979"
+ 6820496E74657265
+ 73742047726F7570
+ 2C2031393739
+ (fig-forth-auto680):05384
+2A26 84 (fig-forth-auto680):05385 FCB $84
+2A27 544153 (fig-forth-auto680):05386 FCC 'TAS' ; 'TASK'
+2A2A CB (fig-forth-auto680):05387 FCB $CB
+2A2B 29F6 (fig-forth-auto680):05388 FDB FORTH-8
+2A2D 17B61662 (fig-forth-auto680):05389 TASK FDB DOCOL,SEMIS
+ (fig-forth-auto680):05390 *
+ 2A31 (fig-forth-auto680):05391 REND EQU * ( first empty location in dictionary )
+ (fig-forth-auto680):05392
+ (fig-forth-auto680):05393
+ (fig-forth-auto680):05394
+ (fig-forth-auto680):05395
+ (fig-forth-auto680):05396
+ (fig-forth-auto680):05397
+ (fig-forth-auto680):05398
+ (fig-forth-auto680):05399 PAGE
+ (fig-forth-auto680):05400 OPT L
+ (fig-forth-auto680):05401 END
--- /dev/null
+ OPT PRT
+
+* fig-FORTH FOR 6809
+* ASSEMBLY SOURCE LISTING
+
+* RELEASE 0
+* JAN 2019
+* WITH COMPILER SECURITY
+* AND VARIABLE LENGTH NAMES
+*
+* Adapted by Joel Matthew Rees
+* from fig-FORTH for 6800 by Dave Lion, et. al.
+
+* This free/libre/open source publication is provided
+* through the courtesy of:
+* FORTH
+* INTEREST
+* GROUP
+* fig
+* and other interested parties.
+
+* Ancient address:
+* P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
+* URL: http://www.forth.org
+* Further distribution must include this notice.
+ PAGE
+ NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
+ OPT NOG,PAG
+* filename fig-forth-auto6809opt.asm
+* === FORTH-6809 {date} {time}
+
+
+* Permission is hereby granted, free of charge, to any person obtaining a copy
+* of this software and associated documentation files (the "Software"), to deal
+* in the Software without restriction, including without limitation the rights
+* to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+* copies of the Software, and to permit persons to whom the Software is
+* furnished to do so, subject to the following conditions:
+*
+* The above copyright notice and this permission notice shall be included in
+* all copies or substantial portions of the Software.
+
+* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+* THE SOFTWARE.
+*
+* "Associated documentation" for this declaration of license
+* shall be interpreted to include only the comments in this file,
+* or, if the code is split into multiple files,
+* all files containing the complete source.
+*
+* This is the MIT model license, as published by the Open Source Consortium,
+* with associated documentation defined.
+* It was chosen to reflect the spirit of the original
+* terms of use, which used archaic legal terminology.
+*
+
+* Authors of the 6800 model:
+* === Primary: Dave Lion,
+* === with help from
+* === Bob Smith,
+* === LaFarr Stuart,
+* === The Forth Interest Group
+* === PO Box 1105
+* === San Carlos, CA 94070
+* === and
+* === Unbounded Computing
+* === 1134-K Aster Ave.
+* === Sunnyvale, CA 94086
+*
+NATWID EQU 2 ; bytes per natural integer/pointer
+* The original version was developed on an AMI EVK 300 PROTO
+* system using an ACIA for the I/O.
+* This version is developed targeting the Tandy Color Computer.
+
+* All terminal 1/0
+* is done in three subroutines:
+* PEMIT ( word # 182 )
+* PKEY ( 183 )
+* PQTERM ( 184 )
+*
+* The FORTH words for disc related I/O follow the model
+* of the FORTH Interest Group, but have not yet been
+* tested using a real disc.
+*
+* Addresses in the 6800 implementation reflect the fact that,
+* on the development system, it was convenient to
+* write-protect memory at hex 1000, and leave the first
+* 4K bytes write-enabled. As a consequence, code from
+* location $1000 to lable ZZZZ could be put in ROM.
+* Minor deviations from the model were made in the
+* initialization and words ?STACK and FORGET
+* in order to do this.
+* Those deviations will be altered in this
+* implementation for the 6809 -- Color Computer.
+*
+
+*
+MEMT32 EQU $7FFF absolute end of all ram
+MEMT16 EQU $3FFF
+MEMTOP EQU MEMT32 ; tentative guess
+ACIAC EQU $FBCE the ACIA control address and
+ACIAD EQU ACIAC+1 data address for PROTO
+ PAGE
+* 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
+* **** ******************************* ******* ******
+* 2nd through 4th per-user tables
+* 4000|7D00
+USERSZ EQU 256 ; (Addressable by DP)
+USER16 EQU 1 ; We can change these for ROMPACK or 64K.
+USER32 EQU 4
+USERCT EQU USER32
+IUP16 EQU MEMT16+1-USER16*USERSZ
+IUP32 EQU MEMT32+1-USER32*USERSZ
+IUP EQU IUP32
+IUPDP EQU IUP/256
+* user tables of variables
+* registers & pointers for the virtual machine
+* scratch area used by various words
+* 3F00|7C00 <== UP (DICTPT)
+* 3EFF|7BFF HI
+* substitute for disc mass memory
+RAMSCR EQU 3
+SCRSZ EQU 1024
+* 3300|7000 LO,MEMEND
+RAMD16 EQU IUP16-RAMSCR*SCRSZ
+RAMD32 EQU IUP32-RAMSCR*SCRSZ
+RAMDSK EQU RAMD32
+MEME16 EQU RAMD16
+MEME32 EQU RAMD32
+MEMEND EQU MEME32
+* 32FF|6FFF
+* 4 buffer sectors of VIRTUAL MEMORY
+NBLK EQU 4 ; # of disc buffer blocks for virtual memory
+* Should NBLK be SCRSZ/SECTSZ?
+* each block is SECTSZ+SECTRL bytes in size,
+* holding SECTSZ characters
+SECTSZ EQU 256
+SECTRL EQU 8
+BUFSZ EQU (SECTSZ+SECTRL)*NBLK
+* 2EE0|6BE0 FIRST
+BUFB16 EQU MEME16-BUFSZ
+BUFB32 EQU MEME32-BUFSZ
+BUFBAS EQU BUFB32
+* "end" of "usable ram" -- in 16K
+* 2EE0|6BE0 <== RP RINIT
+IRP16 EQU BUFB16
+IRP32 EQU BUFB32
+IRP EQU IRP32
+* RETURN STACK
+* (64|112 levels nesting)
+RSTK16 EQU 128
+RSTK32 EQU 224
+* (2E60|6B00)
+SFTB16 EQU IRP16-RSTK16
+SFTB32 EQU IRP32-RSTK32
+SFTBND EQU SFTB32
+* INPUT LINE BUFFER
+* holds up to 256 characters
+* and is scanned upward by IN
+* starting at TIB
+TIBSZ EQU 256
+* 2D60|6A00
+ITIB16 EQU SFTB16-TIBSZ
+ITIB32 EQU SFTB32-TIBSZ
+ITIB EQU ITIB32
+* 2D60|6A00 <== IN TIB
+ISP16 EQU ITIB16
+ISP32 EQU ITIB32
+ISP EQU ISP32
+* 2D60|6A00 <== SP SP0,SINIT
+* DATA STACK
+* | grows downward from 2A60|6A00
+* v
+* - -
+* |
+* I DICTIONARY grows upward
+*
+* ???? end of ram-dictionary. <== DICTPT DPINIT
+* "TASK"
+*
+* ???? "FORTH" ( a word ) <=, <== CONTEXT
+* `==== CURRENT
+* start of ram-dictionary.
+*
+* >>>>>> memory from here up must be in RAM area <<<<<<
+*
+* ????
+* 6k of romable "FORTH" <== IP ABORT
+* <== W
+* the VIRTUAL FORTH MACHINE
+*
+* 1208 initialization tables
+* 1204 <<< WARM START ENTRY >>>
+* 1200 <<< COLD START ENTRY >>>
+* 1200 lowest address used by FORTH
+*
+CODEBG EQU $1200
+* CODEBG EQU $3000
+*
+* >>>>>> memory from here down left alone <<<<<<
+* >>>>>> so we can safely call ROM routines <<<<<<
+*
+* 0000
+ PAGE
+***
+*
+* CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
+*
+* IP (hardware Y) points to the current instruction ( pre-increment mode )
+* RP (hardware S) points to last return address pushedin return stack
+* SP (hardware U) points to last byte pushed in data stack
+*
+* Y must be IP when NEXT is entered (if using the inner loop).
+*
+* When A and B hold one 16 bit FORTH data word,
+* A contains the high byte, B, the low byte.
+*
+* UP (hardware DP) is the base of per-task ("user") variables.
+* (Be careful of the stray semantics of "user".)
+*
+* W (hardware X) is the pointer to the "code field" address of native CPU
+* machine code to be executed for the definition of the dictionary word
+* to be executed/currently executing.
+* The following natural integer (word) begins any "parameter section"
+* (body) -- similar to a "this" pointer, but not the same.
+* It may be native CPU machine code, or it may be a global variable,
+* or it may be a list of Forth definition words (addresses).
+*
+* ======
+* This implementation uses the native subroutine architecture
+* rather than a postponed-push call that the 6800 model VM uses
+* to save code and time in leaf routines.
+*
+* This should allow directly calling many of the Forth words
+* from assembly language code.
+* (Be aware of the need for a valid W in some cases.)
+* It won't allow mixing assembly language directly into Forth word lists.
+* ======
+*
+* boolean flags:
+* 0 is false, anything else is true.
+* Most places in this model that set a boolean flag set true as 1.
+* This is in contrast to many models that set a boolean flag as -1.
+*
+***
+
+ PAGE
+* This system is shown with one user (task),
+* but additional users (tasks) may be added
+* by allocating additional user tables:
+*
+ ORG IUP
+UBASE RMB USERSZ
+UBASEX RMB USERSZ data table for extra users
+*
+* Some of this stuff gets initialized during
+* COLD start and WARM start:
+* [ names correspond to FORTH words of similar (no X) name ]
+*
+ ORG IUP
+UORIG EQU *
+* A few useful VM variables
+* Will be removed when they are no longer needed.
+* All are replaced by 6809 registers.
+
+N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
+* SP@,SWAP,DOES>,COLD
+
+
+* These locations are used by the TRACE routine :
+
+TRLIM RMB 1 the count for tracing without user intervention
+TRACEM RMB 1 non-zero = trace mode
+BRKPT RMB 2 the breakpoint address at which
+* the program will go into trace mode
+VECT RMB 2 vector to machine code
+* (only needed if the TRACE routine is resident)
+
+
+* Registers used by the FORTH virtual machine:
+* Starting at $OOFO:
+
+
+W RMB 2 the instruction register points to 6800 code
+* This is not exactly accurate. Points to the definiton body,
+* which is native CPU machine code when it is native CPU machine code.
+IP RMB 2 the instruction pointer points to pointer to 6800 code
+RP RMB 2 the return stack pointer
+UP RMB 2 the pointer to base of current user's 'USER' table
+* ( altered during multi-tasking )
+*
+*UORIG RMB 6 3 reserved variables
+ RMB 6 3 reserved variables
+XSPZER RMB 2 initial top of data stack for this user
+XRZERO RMB 2 initial top of return stack
+XTIB RMB 2 start of terminal input buffer
+XWIDTH RMB 2 name field width
+XWARN RMB 2 warning message mode (0 = no disc)
+XFENCE RMB 2 fence for FORGET
+XDICTP RMB 2 dictionary pointer
+XVOCL RMB 2 vocabulary linking
+XBLK RMB 2 disc block being accessed
+XIN RMB 2 scan pointer into the block
+XOUT RMB 2 cursor position
+XSCR RMB 2 disc screen being accessed ( O=terminal )
+XOFSET RMB 2 disc sector offset for multi-disc
+XCONT RMB 2 last word in primary search vocabulary
+XCURR RMB 2 last word in extensible vocabulary
+XSTATE RMB 2 flag for 'interpret' or 'compile' modes
+XBASE RMB 2 number base for I/O numeric conversion
+XDPL RMB 2 decimal point place
+XFLD RMB 2
+XCSP RMB 2 current stack position, for compile checks
+XRNUM RMB 2
+XHLD RMB 2
+XDELAY RMB 2 carriage return delay count
+XCOLUM RMB 2 carriage width
+IOSTAT RMB 2 last acia status from write/read
+ RMB 2 ( 4 spares! )
+ RMB 2
+ RMB 2
+ RMB 2
+
+
+
+
+*
+*
+* end of user table, start of common system variables
+*
+*
+*
+XUSE RMB 2
+XPREV RMB 2
+ RMB 4 ( spares )
+
+ PAGE
+* The FORTH program ( address $1200 to about $27FF ) will be written
+* so that it can be in a ROM, or write-protected if desired,
+* but right now we're just getting it running.
+ ORG CODEBG
+
+* ######>> screen 3 <<
+*
+***************************
+** C O L D E N T R Y **
+***************************
+ORIG NOP
+* JMP CENT
+ LBSR CENT
+***************************
+** W A R M E N T R Y **
+***************************
+ NOP
+* JMP WENT warm-start code, keeps current dictionary intact
+ LBSR WENT warm-start code, keeps current dictionary intact
+ SETDP IUPDP
+
+*
+******* startup parmeters **************************
+*
+ FDB $6809,0000 cpu & revision
+ FDB 0 topmost word in FORTH vocabulary
+* BACKSP FDB $7F backspace character for editing
+BACKSP FDB $08 backspace character for editing
+UPINIT FDB UORIG initial user area
+* UPINIT FDB UORIG initial user area
+SINIT FDB ISP ; initial top of data stack
+* SINIT FDB ORIG-$D0 initial top of data stack
+RINIT FDB IRP ; initial top of return stack
+* RINIT FDB ORIG-2 initial top of return stack
+ FDB ITIB ; terminal input buffer
+* FDB ORIG-$D0 terminal input buffer
+ FDB 31 initial name field width
+ FDB 0 initial warning mode (0 = no disc)
+FENCIN FDB REND initial fence
+DPINIT FDB REND cold start value for DICTPT
+VOCINT FDB FORTH+4*NATWID
+COLINT FDB 132 initial terminal carriage width
+DELINT FDB 4 initial carriage return delay
+****************************************************
+*
+ PAGE
+*
+* ######>> screen 13 <<
+* These were of questionable use anyway,
+* kept here now to satisfy the assembler and show hints.
+* They're too much trouble to use with native subroutine call anyway.
+* PULABX PULS A ; 24 cycles until 'NEXT'
+* PULS B ;
+* PULABX PULU A,B ; ?? cycles until 'NEXT'
+* STABX STA 0,X 16 cycles until 'NEXT'
+* STB 1,X
+* STABX STD 0,X ; ?? cycles until 'NEXT'
+ BRA NEXT
+* GETX LDA 0,X 18 cycles until 'NEXT'
+* LDB 1,X
+* GETX LDD 0,X ?? cycles until 'NEXT'
+* PUSHBA PSHS B ; 8 cycles until 'NEXT'
+* PSHS A ;
+* PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
+
+
+*
+* "NEXT" takes ?? cycles if TRACE is removed,
+*
+* and ?? cycles if trace is present and NOT tracing.
+*
+* = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
+* =
+* NEXT itself might just completely go away.
+* About the only reason to keep it is to allowing executing a list
+* which allows a cheap TRACE routine.
+*
+* NEXT is a loop which implements the Forth VM.
+* It basically cycles through calling the code out of code lists,
+* one at a time.
+* Using a native CPU return for this uses a few extra cycles per call,
+* compared to simply jumping to each definition and jumping back
+* to the known beginning of the loop,
+* but the loop itself is really only there for convenience.
+*
+* This implementation uses the native subroutine call,
+* to break the wall between Forth code and non-Forth code.
+*
+* NEXT LDX IP
+* LEAX 1,X ; pre-increment mode
+* LEAX 1,X ;
+* STX IP
+NEXT ; IP is Y, push before using, pull before you come back here.
+*
+* NEXT2 LDX 0,X get W which points to CFA of word to be done
+NEXT2 LDX ,Y++ get W which points to CFA of word to be done
+ BSR DBGNAM
+ BSR DBGREG
+* But NEXT2 is too much trouble to use with subroutine threading anyway.
+* NEXT3 STX W
+NEXT3 ; W is X until you use X for something else. (TOS points back here.)
+* But NEXT3 is too much trouble to use with subroutine threading anyway.
+* LDX 0,X get VECT which points to executable code
+* =
+* The next instruction could be patched to JMP TRACE =
+* if a TRACE routine is available: =
+* =
+* JMP 0,X
+
+ JSR [,X] ; Saving the postinc cycles,
+* ; but X must be bumped NATWID to the parameters.
+* NOP
+* JMP TRACE ( an alternate for the above )
+ BSR DBGREG ( an alternate for the above )
+* In other words, with the call and the NOP,
+* there is room to patch the call with a JMP to your TRACE
+* routine, which you have to provide.
+ BRA NEXT
+*
+DBGNAM PSHS CC,D,X,Y
+ TST <TRACEM
+ BEQ DBGNrt
+ LEAX -3,X
+DBGNlf LDB ,-X
+ BPL DBGNlf
+ LDY #$4C0
+ LDB ,X+
+DBGNlp LDB ,X+
+ BMI DBGNll
+ STB ,Y+
+ BRA DBGNlp
+DBGNll ANDB #$7F
+ STB ,Y+
+ LDB #$60
+ BRA DBGNlt
+DBGNlc STB ,Y+
+DBGNlt CMPY #$4E0
+ BLO DBGNlc
+DBGNrt PULS CC,D,X,Y,PC
+*
+*
+MKhxBh LSRB
+ LSRB
+ LSRB
+ LSRB
+MKhxBl ANDB #$0F
+ ADDB #$30
+ CMPB #$39
+ BLS MKhxBx
+ ADDB #$C7 ; ($40-$39)-$40
+MKhxBx RTS
+*
+OUThxA EXG A,B
+ BSR OUThxB
+ EXG A,B
+ RTS
+*
+OUThxD BSR OUThxA
+OUThxB PSHS B
+ BSR MKhxBh
+ STB ,X+
+ LDB ,S
+ BSR MKhxBl
+ STB ,X+
+ PULS B,PC
+*
+DBGREG PSHS U,Y,X,DP,B,A,CC
+ TST <TRACEM
+ LBEQ DBGRrt
+ LEAY DBGRLB,PCR
+ LDX #$4E0
+DBGRlp LDD ,Y++
+ BEQ DBGRdn
+ STD ,X++
+ BRA DBGRlp
+DBGRdn LDX #$500
+ LDA 3,S ; DP
+ LDB ,S ; CC
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 3*NATWID+4,S ; PC:505
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ TFR S,D ; 509
+ ADDD #4*NATWID+4
+ BSR OUThxD
+ LDD 2*NATWID+4,S ; U:50E
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 1*NATWID+4,S ; Y:513
+ BSR OUThxD
+ LDD 0*NATWID+4,S ; X at 517
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 1,S ; D at 51C
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ LDD [3*NATWID+4,S] ; PC
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 4*NATWID+4,S ; S
+ BSR OUThxD
+ LDD [2*NATWID+4,S] ; U
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD [1*NATWID+4,S] ; Y
+ LBSR OUThxD
+ LDD [0*NATWID+4,S] ; X
+ LBSR OUThxD
+ LDB #$60
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ LDB #0
+ EXG B,DP
+DBGRkl JSR [$A000]
+ BEQ DBGRkl
+ STD $43E
+ EXG DP,B
+ CMPA #$55 ; 'U'
+ BEQ DBGRdU
+ CMPA #$53 ; 'S'
+ BEQ DBGRdS
+ CMPA #$49 ; 'I'
+ BNE DBGRrt
+DBGRin LDD <XTIB
+ ADDD <XIN
+ TFR D,Y
+ LBSR OUThxD
+ LDB #$3a ; ':'
+ STB ,X+
+ LDA <XCOLUM
+DBGRip LDB ,Y+
+ STB ,X+
+ BEQ DBGRrt
+DBGRit DECA
+ BNE DBGRip
+ BRA DBGRrt
+DBGRdS TFR S,Y
+ BRA DBGRst
+DBGRsp LDD ,Y++
+ LBSR OUThxD
+ LDB #$60
+ STB ,X+
+DBGRst CMPY <XRZERO
+ BLO DBGRsp
+ LDB #$3a ; ':'
+ STB ,X+
+ LDB #$55
+ STB ,X+
+DBGRdU LDY 2*NATWID+4,S
+ BRA DBGRut
+DBGRup LDD ,Y++
+ LBSR OUThxD
+ LDB #$60
+ STB ,X+
+DBGRut CMPY <XSPZER
+ BLO DBGRup
+DBGRrt PULS CC,A,B,DP,X,Y,U,PC
+DBGRLB FCC 'DPCC PC S U Y X A B '
+ FDB 0,0
+
+
+*
+* =
+* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+
+
+ PAGE
+*
+* ======>> 1 <<
+* ( --- n )
+* Pushes the following natural width integer from the instruction stream
+* as a literal, or immediate value.
+*
+* FDB {OP}
+* FDB {OP}
+* FDB LIT
+* FDB LITERAL-TO-BE-PUSHED
+* FDB {OP}
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* (Note that there is no compile-only flag in the fig model.)
+*
+* See (FIND), or PFIND , for layout of the header format.
+*
+ FCB $83
+ FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
+ FCB $D4 ; 'T'|'\x80' ; character code for T, with high bit set.
+ FDB 0 ; link of zero to terminate dictionary scan
+LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
+ LDD ,Y++
+ PSHU A,B
+ RTS
+* LDX IP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX IP
+* LDA 0,X
+* LDB 1,X
+* JMP PUSHBA
+*
+* ######>> screen 14 <<
+* ======>> 2 <<
+* ( --- n )
+* Pushes the following byte from the instruction stream
+* as a literal, or immediate value.
+*
+* FDB {OP}
+* FDB {OP}
+* FDB LIT8
+* FCB LITERAL-TO-BE-PUSHED
+* FDB {OP}
+*
+* If this is kept, it should have a header for TRACE to read.
+* If the data bus is wider than a byte, you don't want to do this.
+* Byte shaving like this is often counter-productive anyway.
+* Changing the name to LIT8, hoping that will be more understandable.
+* Also, see comments for LIT.
+* (Note that there is no compile-only flag in the fig model.)
+ FCB $84
+ FCC 'LIT' ; 'LIT8' : NOTE: this is different from LITERAL
+ FCB $B8
+ FDB LIT-6
+LIT8 FDB *+NATWID (this was an invisible word, with no header)
+ LDB ,Y+ ; This also is meaningless in native code.
+ CLRA
+ PSHU A,B
+ RTS
+* LDX IP
+* LEAX 1,X ;
+* STX IP
+* CLRA ;
+* LDB 1,X
+* JMP PUSHBA
+*
+* ( n off --- n )
+* off is offset in video buffer area.
+ FCB $87
+ FCC 'SHOWTO' ; 'SHOWTOS'
+ FCB $D3 ; 'S'
+ FDB LIT8-7
+SHOTOS FDB *+NATWID
+ LDX #$400
+ LDD ,U++
+ LEAX D,X
+ LDD ,U
+ LBSR OUThxD
+ RTS
+*
+ FCB $85
+ FCC 'TROF' ; 'TROFF'
+ FCB $C6 ; 'F'|$80
+ FDB SHOTOS-10
+TROFF FDB *+NATWID
+ CLR <TRACEM
+ RTS
+*
+ FCB $84
+ FCC 'TRO' ; 'TRON'
+ FCB $CE ; 'N'|$80
+ FDB TROFF-8
+TRON FDB *+NATWID
+ INC <TRACEM
+ RTS
+*
+* ======>> 3 <<
+* ( adr --- )
+* Jump to address on stack. Used by the "outer" interpreter to
+* interactively invoke routines.
+* Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
+ FCB $87
+ FCC 'EXECUT' ; 'EXECUTE'
+ FCB $C5
+ FDB TRON-7
+EXEC FDB *+NATWID
+ PULU X ; Gotta have W anyway, just in case.
+ JMP [,X] ; Tail return.
+* TFR S,X ; TSX :
+* LDX 0,X get code field address (CFA)
+* LEAS 1,S ; pop stack
+* LEAS 1,S ;
+* JMP NEXT3
+*
+* ######>> screen 15 <<
+* ======>> 4 <<
+* ( --- ) C
+* Add the following word from the instruction stream to the
+* instruction pointer (Y++). Causes a program branch in Forth code stream.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $86
+ FCC 'BRANC' ; 'BRANCH'
+ FCB $C8
+ FDB EXEC-10
+BRAN FDB ZBYES ; Go steal code in ZBRANCH
+
+* Moving code around to optimize the branch taking case in 0BRANCH.
+ZBNO LEAY NATWID,Y ; No branch.
+ RTS
+* ======>> 5 <<
+* ( f --- ) C
+* BRANCH if flag is zero.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $87
+ FCC '0BRANC' ; '0BRANCH'
+ FCB $C8
+ FDB BRAN-9
+ZBRAN FDB *+NATWID
+ LDD ,U++
+ BNE ZBNO
+ZBYES LDD ,Y++
+ LEAY D,Y ; IP is postinc
+ RTS
+* PULS A ;
+* PULS B ;
+* PSHS B ; ** emulating ABA:
+* ADDA ,S+ ;
+* BNE ZBNO
+* BCS ZBNO
+* ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
+* LDB 3,X
+* LDA 2,X
+* ADDB IP+1
+* ADCA IP
+* STB IP+1
+* STA IP
+* JMP NEXT
+* ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
+* LEAX 1,X ; jump over branch delta
+* LEAX 1,X ;
+* STX IP
+* JMP NEXT
+*
+* ######>> screen 16 <<
+* ======>> 6 <<
+* ( --- ) ( limit index *** limit index+1) C
+* ( limit index *** )
+* Counting loop primitive. The counter and limit are the top two
+* words on the return stack. If the updated index/counter does
+* not exceed the limit, a branch occurs. If it does, the branch
+* does not occur, and the index and limit are dropped from the
+* return stack.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $86
+ FCC '(LOOP' ; '(LOOP)'
+ FCB $A9
+ FDB ZBRAN-10
+XLOOP FDB *+NATWID
+ LDD #1 ; Borrowing from BIF-6809.
+XLOOPA ADDD NATWID,S ; Dodge the return address.
+ STD NATWID,S
+ SUBD 2*NATWID,S
+ BLT ZBYES ; signed
+XLOOPN LEAY NATWID,Y
+ LDX ,S ; synthetic return
+ LEAS 3*NATWID,S ; Clean up the index and limit.
+ JMP ,X
+* CLRA ;
+* LDB #1 get set to increment counter by 1 (Clears N.)
+* BRA XPLOP2 go steal other guy's code!
+*
+* ======>> 7 <<
+* ( n --- ) ( limit index *** limit index+n ) C
+* ( limit index *** )
+* Loop with a variable increment. Terminates when the index
+* crosses the boundary from one below the limit to the limit. A
+* positive n will cause termination if the result index equals the
+* limit. A negative n must cause the index to become less than
+* the limit to cause loop termination.
+*
+* Note that the end conditions are not symmetric around zero.
+*
+* In native processor code, there should be a better way, use that instead.
+* More specifically, DO NOT CALL THIS from assembly language code.
+* This is only for Forth code stream.
+* Also, see comments for LIT.
+ FCB $87
+ FCC '(+LOOP' ; '(+LOOP)'
+ FCB $A9
+ FDB XLOOP-9
+XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
+ LDD ,U++ ; inc val
+ BPL XLOOPA ; Steal plain loop code for forward count.
+ ADDD NATWID,S ; Dodge the return address
+ STD NATWID,S
+ SUBD 2*NATWID,S
+ BGT ZBYES ; signed
+ BRA XLOOPN ; This path is less time-sensitive.
+*
+* This should work, but I want to use tested code.
+* PULU A,B ; Get the increment.
+* XPLOP2 PULS X ; Pre-clear the return stack.
+* PSHU A ; Save the direction in high bit.
+* ADDD ,S ; Count.
+* STD ,S ; Update.
+* SUBD NATWID,S ; Check limit.
+**
+** I think this should work:
+* EORA ,U+ ; dir < 0 and (count - limit) >= 0
+* BPL XPLONO ; or dir >= 0 and (count - limit) < 0
+* LDD ,Y++
+* LEAY D,Y ; IP is postinc
+* JMP ,X
+* XPLONO LEAS 2*NATWID,S
+* JMP ,X ; synthetic return
+*
+* This definitely should work:
+* TST ,U+ ; Get the sign
+* BPL XPLOF ;
+* CMPD NATWID,S
+* BMI XPLONO
+* XPLOYE LDD ,Y++
+* LEAY D,Y ; IP is postinc
+* JMP ,X
+* XPLOF CMPD NATWID,S
+* BMI XPLOYE
+* XPLONO LEAS 2*NATWID,S
+* JMP ,X ; synthetic return
+*
+* 6800 Probably could have used the exclusive-or method, too.:
+* PULS A ; get increment
+* PULS B ;
+* XPLOP2 TSTA ;
+* BPL XPLOF forward looping
+* BSR XPLOPS
+* ORCC #$01 ; SEC :
+* SBCB 5,X
+* SBCA 4,X
+* BPL ZBYES
+* BRA XPLONO fall through
+*
+* the subroutine :
+* XPLOPS LDX RP
+* ADDB 3,X add it to counter
+* ADCA 2,X
+* STB 3,X store new counter value
+* STA 2,X
+* RTS
+*
+* XPLOF BSR XPLOPS
+* SUBB 5,X
+* SBCA 4,X
+* BMI ZBYES
+*
+* XPLONO LEAX 1,X ; done, don't branch back
+* LEAX 1,X ;
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX RP
+* BRA ZBNO use ZBRAN to skip over unused delta
+*
+* ######>> screen 17 <<
+* ======>> 8 <<
+* ( limit index --- ) ( *** limit index )
+* Move the loop parameters to the return stack. Synonym for D>R.
+ FCB $84
+ FCC '(DO' ; '(DO)'
+ FCB $A9
+ FDB XPLOOP-10
+XDO FDB *+NATWID This is the RUNTIME DO, not the COMPILING DO
+ LDX ,S ; Save the return address.
+ PULU A,B
+ PSHS A,B
+ PULU A,B ; Maintain order.
+ STD NATWID,S
+ JMP ,X ; synthetic return
+*
+* LDX RP
+* LEAX -1,X ;
+* LEAX -1,X ;
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* PULS A ;
+* PULS B ;
+* STA 2,X
+* STB 3,X
+* PULS A ;
+* PULS B ;
+* STA 4,X
+* STB 5,X
+* JMP NEXT
+*
+* ======>> 9 <<
+* ( --- index ) ( limit index *** limit index )
+* Copy the loop index from the return stack. Synonym for R.
+ FCB $81 I
+ FCB $C9
+ FDB XDO-7
+I FDB *+NATWID
+ LDD NATWID,S ; Dodge return address.
+ PSHU A,B
+ RTS
+* LDX RP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* JMP GETX
+*
+* ######>> screen 18 <<
+* ======>> 10 <<
+* ( c base --- false )
+* ( c base --- n true )
+* Translate C in base, yielding a translation valid flag. If the
+* translation is not valid in the specified base, only the false
+* flag is returned.
+ FCB $85
+ FCC 'DIGI' ; 'DIGIT'
+ FCB $D4
+ FDB I-4
+DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
+ LDD NATWID,U ; Check the whole thing.
+ SUBD #$30 ; ascii zero
+ BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+ CMPD #$A
+ BMI DIGIT0 IF '9' OR LESS
+ CMPD #$11
+ BMI DIGIT2 if less than 'A'
+ CMPD #$2B
+ BPL DIGIT2 if greater than 'Z'
+ SUBD #7 translate 'A' thru 'F'
+DIGIT0 CMPD ,U ; Check the base.
+ BPL DIGIT2 if not less than the base
+ STD NATWID,U ; Store converted digit. (High byte known zero.)
+ LDD #1 ; set valid flag
+DIGIT1 STD ,U ; store the flag
+ RTS NEXT
+DIGIT2 LDD #0 ; set not valid flag
+ LEAU NATWID,U ; pop base
+ BRA DIGIT1
+* TFR S,X ; TSX :
+* LDA 3,X
+* SUBA #$30 ascii zero
+* BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+* CMPA #$A
+* BMI DIGIT0 IF '9' OR LESS
+* CMPA #$11
+* BMI DIGIT2 if less than 'A'
+* CMPA #$2B
+* BPL DIGIT2 if greater than 'Z'
+* SUBA #7 translate 'A' thru 'F'
+* DIGIT0 CMPA 1,X
+* BPL DIGIT2 if not less than the base
+* LDB #1 set flag
+* STA 3,X store digit
+* DIGIT1 STB 1,X store the flag
+* JMP NEXT
+* DIGIT2 CLRB ;
+* LEAS 1,S ;
+* LEAS 1,S ; pop bottom number
+* TFR S,X ; TSX :
+* STB 0,X make sure both bytes are 00
+* BRA DIGIT1
+*
+* ######>> screen 19 <<
+*
+* The word definition format in the dictionary:
+*
+* (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
+*
+* NFA (name field address):
+* char-count + $80 Length of symbol name, flagged with high bit set.
+* char 1 Characters of symbol name.
+* char 2
+* ...
+* char n + $80 symbol termination flag (char set < 128 code points)
+* LFA (link field address):
+* link high byte \___pointer to previous word in list
+* link low byte / -- Combined allocation/dictionary list. --
+* CFA (code field address):
+* CFA high byte \___pointer to native CPU machine code
+* CFA low byte / -- Consider this the characteristic code. --
+* PFA (parameter field address):
+* parameter fields -- Machine code for low-level native machine CPU code,
+* " instruction list for high-level Forth code,
+* " constant data for constants, pointers to per task variables,
+* " space for variables, for global variables, etc.
+*
+* In the case of native CPU machine code, the address at CFA will be PFA.
+
+* Definition attributes:
+FIMMED EQU $40 ; Immediate word flag.
+FSMUDG EQU $20 ; Smudged => definition not ready.
+CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte.
+* Note that the SMUDGE bit is not masked out.
+*
+* But we really want more (Thinking for a new model, need one more byte):
+* FCOMPI EQU $10 ; Compile-time-only.
+* FASSEM EQU $08 ; Assembly-language code only.
+* F4THLV EQU $04 ; Must not be called from assembly language code.
+* These would require some significant adjustments to the model.
+* We also want to put the low-level VM stuff in its own vocabulary.
+*
+* ======>> 11 <<
+* (FIND) ( name vocptr --- locptr length true )
+* ( name vocptr --- false )
+* Search vocabulary for a symbol called name.
+* name is a pointer to a high-bit bracket string with length head.
+* vocptr is a pointer to the NFA of the tail-end (LATEST) definition
+* in the vocabulary to be searched.
+* Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
+ FCB $86
+ FCC '(FIND' ; '(FIND)'
+ FCB $A9
+ FDB DIGIT-8
+PFIND FDB *+NATWID
+ PSHS Y ; Have to track two pointers.
+* Use the stack and registers instead of temp area N.
+PA0 EQU NATWID ; pointer to the length byte of name being searched against
+PD EQU 0 ; pointer to NFA of dict word being checked
+*
+* INC <TRACEM
+* LBSR DBGREG
+ LDX PD,U ; Start in on the vocabulary (NFA).
+PFNDLP LDY PA0,U ; Point to the name to check against.
+ LDB ,X+ ; get dict name length byte
+ TFR B,A ; Save it in case it matches.
+ ANDB #CTMASK
+* LBSR DBGREG
+ CMPB ,Y+ ; Compare lengths
+* LBSR DBGREG
+ BNE PFNDUN
+PFNDBR LDB ,X+
+ TSTB ; ; Is high bit of character in dictionary entry set?
+* LBSR DBGREG
+ BPL PFNDCH
+* LBSR DBGREG
+ ANDB #$7F ; Clear high bit from dictionary.
+ CMPB ,Y+ ; Compare "last" characters.
+* LBSR DBGREG
+ BEQ FOUND ; Matches even if dictionary actual length is shorter.
+PFNDLN LDX ,X++ ; Get previous link in vocabulary.
+* LBSR DBGREG
+ BNE PFNDLP ; Continue if link not=0
+*
+* not found :
+ LEAU NATWID,U ; Return only false flag.
+ LDD #0
+ STD ,U
+* LBSR DBGREG
+* DEC <TRACEM
+ PULS Y,PC
+*
+PFNDCH CMPB ,Y+ ; Compare characters.
+* LBSR DBGREG
+ BEQ PFNDBR
+PFNDUN
+PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
+* LBSR DBGREG
+ BPL PFNDSC
+* LBSR DBGREG
+ BRA PFNDLN
+*
+* found :
+*
+FOUND LEAX 2*NATWID,X
+* LBSR DBGREG
+ STX NATWID,U
+ TFR A,B
+ CLRA
+ STD ,U
+* LBSR DBGREG
+ LDB #1
+ PSHU A,B
+* LBSR DBGREG
+* DEC <TRACEM
+ PULS Y,PC
+*
+* 6800 model:
+* NOP ; Probably leftovers from a debugging session.
+* NOP
+* PD EQU N ptr to dict word being checked
+* PA0 EQU N+2
+* PA EQU N+4
+* PC EQU N+6
+* LDX #PD
+* LDB #4
+* PFIND0 PULS A ; loop to get arguments
+* STA 0,X
+* LEAX 1,X ;
+* DECB ;
+* BNE PFIND0
+*
+* LDX PD
+* PFNDLP LDB 0,X get count dict count
+* STB PC
+* ANDB #$3F
+* LEAX 1,X ;
+* STX PD update PD
+* LDX PA0
+* LDA 0,X get count from arg
+* LEAX 1,X ;
+* STX PA intialize PA
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ; compare lengths
+* BNE PFNDUN
+* PFNDBR LDX PA
+* LDA 0,X
+* LEAX 1,X ;
+* STX PA
+* LDX PD
+* LDB 0,X
+* LEAX 1,X ;
+* STX PD
+* TSTB ; is dict entry neg. ?
+* BPL PFNDCH
+* ANDB #$7F clear sign
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ;
+* BEQ FOUND
+* PFNDLN LDX 0,X get new link
+* BNE PFNDLP continue if link not=0
+*
+* not found :
+*
+* CLRA ;
+* CLRB ;
+* JMP PUSHBA
+* PFNDCH PSHS B ; ** emulating CBA:
+* CMPA ,S+ ;
+* BEQ PFNDBR
+* PFNDUN LDX PD
+* PFNDSC LDB 0,X scan forward to end of this name
+* LEAX 1,X ;
+* BPL PFNDSC
+* BRA PFNDLN
+*
+* found :
+*
+* FOUND LDA PD compute CFA
+* LDB PD+1
+* ADDB #4
+* ADCA #0
+* PSHS B ;
+* PSHS A ;
+* LDA PC
+* PSHS A ;
+* CLRA ;
+* PSHS A ;
+* LDB #1
+* JMP PUSHBA
+*
+* PSHS A ; Left over from a stray copy-paste, I guess.
+* CLRA ;
+* PSHS A ;
+* LDB #1
+* JMP PUSHBA
+*
+* ######>> screen 20 <<
+* ======>> 12 <<
+* ( buffer ch --- buffer symboloffset delimiteroffset scancount )
+* ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
+* ( buffer ch --- buffer nuloffset onepast scancount )
+* Scan buffer for a symbol delimited by ch or ASCII NUL,
+* return the length of the buffer region scanned,
+* the offset to the trailing delimiter,
+* and the offset of the first character of the symbol.
+* Leave the buffer on the stack.
+* Scancount is also offset to first character not yet looked at.
+* If no symbol in buffer, scancount and symboloffset point to NUL
+* and delimiteroffset points one beyond for some reason.
+* On trailing NUL, delimiteroffset == scancount.
+* (Buffer is the address of the buffer array to scan.)
+* (This is a bit too tricky, really.)
+ FCB $87
+ FCC 'ENCLOS' ; 'ENCLOSE'
+ FCB $C5
+ FDB PFIND-9
+ENCLOS FDB *+NATWID
+ LDA 1,U ; Delimiter character to match against in A.
+ LDX NATWID,U ; Buffer to scan in.
+ CLRB ; Initialize offset. (Buffer < 256 wide!)
+* Scan to a non-delimiter or a NUL
+ENCDEL TST B,X ; NUL ?
+ BEQ ENCNUL
+ CMPA B,X ; Delimiter?
+ BNE ENC1ST
+ INCB ; count character
+ BRA ENCDEL
+* Found first character. Save the offset.
+ENC1ST STB 1,U ; Found first non-delimiter character --
+ CLR ,U ; store the count, zero high byte.
+* Scan to a delimiter or a NUL
+ENCSYM TST B,X ; NUL ?
+ BEQ ENC0TR
+ CMPA B,X ; delimiter?
+ BEQ ENCEND
+ INCB
+ BRA ENCSYM
+* Found end of symbol. Push offset to delimiter found.
+ENCEND CLRA ; high byte -- buffer < 255 wide!
+ PSHU A,B ; Offset to seen delimiter.
+* Advance and push address of next character to check.
+ ADDD #1 ; In case offset was 255.
+ PSHU A,B
+ RTS
+* Found NUL before non-delimiter, therefore there is no word
+ENCNUL CLRA ; high byte -- buffer < 255 wide!
+ STD ,U ; offset to NUL.
+ ADDD #1 ; Point after NUL to allow (FIND) to match it.
+ PSHU A,B ;
+ SUBD #1 ; Next is not passed NUL.
+ PSHU A,B ; Stealing code will save only one byte.
+ RTS
+* Found NUL following the word instead of delimiter.
+ENC0TR
+* INC <TRACEM
+* LBSR DBGREG
+ CLRA
+ PSHU A,B ; Save offset to first after symbol (NUL)
+* LBSR DBGREG
+ PSHU A,B ; and count scanned.
+* LBSR DBGREG
+* DEC <TRACEM
+ RTS
+* NOTE :
+* FC means offset (bytes) to First Character of next word
+* EW " " to End of Word
+* NC " " to Next Character to start next enclose at
+* ENCLOS FDB *+NATWID
+* LEAS 1,S ;
+* PULS B ; now, get the low byte, for an 8-bit delimiter
+* TFR S,X ; TSX :
+* LDX 0,X
+* CLR N
+* * wait for a non-delimiter or a NUL
+* ENCDEL LDA 0,X
+* BEQ ENCNUL
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ; CHECK FOR DELIM
+* BNE ENC1ST
+* LEAX 1,X ;
+* INC N
+* BRA ENCDEL
+* * found first character. Push FC
+* ENC1ST LDA N found first char.
+* PSHS A ;
+* CLRA ;
+* PSHS A ;
+* wait for a delimiter or a NUL
+* ENCSYM LDA 0,X
+* BEQ ENC0TR
+* PSHS B ; ** emulating CBA:
+* CMPA ,S+ ; ckech for delim.
+* BEQ ENCEND
+* LEAX 1,X ;
+* INC N
+* BRA ENCSYM
+* * found EW. Push it
+* ENCEND LDB N
+* CLRA ;
+* PSHS B ;
+* PSHS A ;
+* * advance and push NC
+* INCB ;
+* JMP PUSHBA
+* found NUL before non-delimiter, therefore there is no word
+* ENCNUL LDB N found NUL
+* PSHS B ;
+* PSHS A ;
+* INCB ;
+* BRA ENC0TR+2 ; ********** POTENTIAL BUG HERE *******
+* ******** Should use labels in case opcodes change! ********
+* found NUL following the word instead of SPACE
+* ENC0TR LDB N
+* PSHS B ; save EW
+* PSHS A ;
+* ENCL8 LDB N save NC
+* JMP PUSHBA
+
+ PAGE
+*
+* ######>> screen 21 <<
+* The next 4 words call system dependant I/O routines
+* which are listed after word "-->" ( lable: "arrow" )
+* in the dictionary.
+*
+* ======>> 13 <<
+* ( c --- )
+* Write c to the output device (screen or printer).
+* ROM Uses the ECB device number at address $6F,
+* -2 is printer, 0 is screen.
+ FCB $84
+ FCC 'EMI' ; 'EMIT'
+ FCB $D4
+ FDB ENCLOS-10
+EMIT FDB *+NATWID
+ PULU D
+ LBSR PEMIT ; PEMIT expects the character in D.
+ INC <XOUT+1
+ BNE EMITDN
+ INC <XOUT
+EMITDN RTS
+* PULS A ;
+* PULS A ;
+* JSR PEMIT
+* LDX UP
+* INC XOUT+1-UORIG,X
+* BNE *+4 ;
+* ****WARNING**** HARD OFFSET: *+4 ****
+* INC XOUT-UORIG,X
+* JMP NEXT
+*
+* ======>> 14 <<
+* ( --- c )
+* ( --- BREAK )
+* Wait for a key from the keyboard.
+* If the key is BREAK, set the high byte (result $FF03).
+ FCB $83
+ FCC 'KE' ; 'KEY'
+ FCB $D9
+ FDB EMIT-7
+KEY FDB *+NATWID
+ LBSR PKEY ; PKEY leaves the key/break code in D.
+ PSHU D
+ RTS
+* JSR PKEY
+* PSHS A ;
+* CLRA ;
+* PSHS A ;
+* JMP NEXT
+*
+* ======>> 15 <<
+* ( --- f )
+* Scan keyboard, but do not wait.
+* Return 0 if no key,
+* BREAK ($ff03) if BREAK is pressed,
+* or key currently pressed.
+ FCB $89
+ FCC '?TERMINA' ; '?TERMINAL'
+ FCB $CC
+ FDB KEY-6
+QTERM FDB *+NATWID
+ LBSR PQTER ; PQTER leaves the flag/key in D.
+ PSHU D
+ RTS
+* JSR PQTER
+* CLRB ;
+* JMP PUSHBA stack the flag
+*
+* ======>> 16 <<
+* ( --- )
+* EMIT a Carriage Return (ASCII CR).
+ FCB $82
+ FCC 'C' ; 'CR'
+ FCB $D2
+ FDB QTERM-12
+CR FDB *+NATWID
+ LBRA PCR ; Nothing really to do here.
+* JSR PCR
+* JMP NEXT
+*
+* ######>> screen 22 <<
+* ======>> 17 <<
+* ( source target count --- )
+* Copy/move count bytes from source to target.
+* Moves ascending addresses,
+* so that overlapping only works if the source is above the destination.
+ FCB $85
+ FCC 'CMOV' ; 'CMOVE' : source, destination, count
+ FCB $C5
+ FDB CR-5
+CMOVE FDB *+NATWID
+ 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
+* DEC <TRACEM
+* PULS A,Y,PC ; #2~10
+* Another way ; takes ( 42+17*count+9*(count/256) cycles )
+* LDD #0 ; #3~3
+* SUBD ,U++ ; #2~9 ; invert the count
+* PSHS A,Y ; #2~8
+* PULU X,Y ; #2~9
+* BEQ CMOVEX ; #2~3
+* CMOVEL
+* LDA ,Y+ ; #2~6
+* STA ,X+ ; #2~6
+* INCB ; #1~2
+* BNE CMOVEL ; #2~3
+* INC ,S ; #2~6
+* BNE CMOVEL ; #2~3
+* CMOVEX
+* PULS A,Y,PC ; #2~10
+* Yet another way ; takes ( 37+29*count cycles )
+* PSHS Y ; #2~7
+* LDX NATWID,U ; #2~6
+* LDY NATWID,U ; #3~7
+* BRA CMOVLE ; #2~3
+* CMOVLP
+* LDA ,Y+ ; #2~6
+* STA ,X+ ; #2~6
+* CMOVLE
+* LDD ,U ; #2~5
+* SUBD #1 ; #3~4
+* STD ,U ; #2~5
+* BPL CMOVLP ; #2~3
+* LEAU 3*NATWID,U ; #2~5
+* PULS Y,PC ; #2~9
+* Yet another way ; takes ( 44+24*odd+33*count/2 cycles )
+* PSHS Y ; #2~7
+* LDX NATWID,U ; #2~6
+* LDY 2*NATWID,U ; #3~7
+* LDD ,U ; #2~5
+* BITB #1 ; #2~2
+* BEQ CMOVLE ; #2~3
+* SUBD #1 ; #3~4
+* STD ,U ; #2~5
+* LDA ,Y+ ; #2~6
+* STA ,X+ ; #2~6
+* BRA CMOVLE ; #2~3
+* CMOVLP
+* LDD ,Y++ ; #2~8
+* STD ,X++ ; #2~8
+* CMOVLI
+* LDD ,U ; #2~5
+* CMOVLE
+* SUBD #2 ; #3~4
+* STD ,U ; #2~5
+* BPL CMOVLP ; #2~3
+* LEAU 3*NATWID,U ; #2~5
+* PULS Y,PC ; #2~9
+* From the 6800 model:
+* CMOVE FDB *+2 takes ( 43+47*count cycles ) on 6800
+* LDX #N
+* LDB #6
+* CMOV1 PULS A ;
+* STA 0,X move parameters to scratch area
+* LEAX 1,X ;
+* DECB ;
+* BNE CMOV1
+* CMOV2 LDA N
+* LDB N+1
+* SUBB #1
+* SBCA #0
+* STA N
+* STB N+1
+* BCS CMOV3
+* LDX N+4
+* LDA 0,X
+* LEAX 1,X ;
+* STX N+4
+* LDX N+2
+* STA 0,X
+* LEAX 1,X ;
+* STX N+2
+* BRA CMOV2
+* CMOV3 JMP NEXT
+*
+* ######>> screen 23 <<
+* ======>> 18 <<
+* ( u1 u2 --- ud )
+* Multiplies the top two unsigned integers,
+* yielding a double integer product.
+ FCB $82
+ FCC 'U' ; 'U*'
+ FCB $AA
+ FDB CMOVE-8
+USTAR FDB *+NATWID
+ LEAU -2*NATWID,U
+ LDA 2*NATWID+1,U ; least
+ LDB 3*NATWID+1,U
+ MUL
+ STD NATWID,U
+ LDA 2*NATWID,U ; most
+ LDB 3*NATWID,U
+ MUL
+ STD ,U
+ LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi)
+ MUL
+ ADDD 1,U
+ BCC USTAR3
+ INC ,U
+USTAR3 STD 1,U
+ LDA 2*NATWID,U ; second inner (u2 hi)
+ LDB 3*NATWID,U ; (u1 lo)
+ MUL
+ ADDD 1,U
+ BCC USTAR4
+ INC ,U
+USTAR4 STD 1,U
+ PULU D,X
+ STD ,U
+ STX NATWID,U
+ RTS
+*
+* from 6800 model:
+* BSR USTARS
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP PUSHBA
+*
+* The following is a subroutine which
+* multiplies top 2 words on stack,
+* leaving 32-bit result: high order word in A,B
+* low order word in 2nd word of stack.
+*
+* USTARS LDA #16 bits/word counter
+* PSHS A ;
+* CLRA ;
+* CLRB ;
+* TFR S,X ; TSX :
+* USTAR2 ROR 5,X shift multiplier
+* ROR 6,X
+* DEC 0,X done?
+* BMI USTAR4
+* BCC USTAR3
+* ADDB 4,X
+* ADCA 3,X
+* USTAR3 RORA ;
+* RORB ; shift result
+* BRA USTAR2
+* USTAR4 LEAS 1,S ; dump counter
+* RTS
+*
+* ######>> screen 24 <<
+* ======>> 19 <<
+* ( ud u --- uremainder uquotient )
+* Divides the top unsigned integer
+* into the second and third words on the stack
+* as a single unsigned double integer,
+* leaving the remainder and quotient (quotient on top)
+* as unsigned integers.
+*
+* The smaller the divisor, the more likely dropping the high word
+* of the quotient loses significant bits. See M/MOD .
+*
+ FCB $82
+ FCC 'U' ; 'U/'
+ FCB $AF
+ FDB USTAR-5
+USLASH FDB *+NATWID
+ LDA #17 ; bit ct
+ PSHS A
+ LDD NATWID,U ; dividend
+USLDIV CMPD ,U ; divisor
+ BHS USLSUB
+ ANDCC #~1 ; carry clear
+ BRA USLBIT
+USLSUB SUBD ,U
+ ORCC #1 ; quotient, (carry set)
+USLBIT ROL 2*NATWID+1,U ; save it
+ ROL 2*NATWID,U
+ DEC ,S ; more bits?
+ BEQ USLR
+ ROLB ; remainder
+ ROLA
+ BCC USLDIV
+ BRA USLSUB
+USLR LEAU NATWID,U
+ LDX NATWID,U
+ STD NATWID,U
+ STX ,U
+ PULS A,PC ; Avoiding a LEAS 1,S by discarding A.
+*
+* from 6800 model:
+* LDA #17
+* PSHS A ;
+* TFR S,X ; TSX :
+* LDA 3,X
+* LDB 4,X
+* USL1 CMPA 1,X
+* BHI USL3
+* BCS USL2
+* CMPB 2,X
+* BCC USL3
+* USL2 ANDCC #~$01 ; CLC :
+* BRA USL4
+* USL3 SUBB 2,X
+* SBCA 1,X
+* ORCC #$01 ; SEC :
+* USL4 ROL 6,X
+* ROL 5,X
+* DEC 0,X
+* BEQ USL5
+* ROLB ;
+* ROLA ;
+* BCC USL1
+* BRA USL3
+* USL5 LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP SWAP+4 reverse quotient & remainder
+*
+* ######>> screen 25 <<
+* ======>> 20 <<
+* ( n1 n2 --- n )
+* Bitwise and the top two integers.
+ FCB $83
+ FCC 'AN' ; 'AND'
+ FCB $C4
+ FDB USLASH-5
+AND FDB *+NATWID
+ PULU A,B
+ ANDB 1,U
+ ANDA ,U
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* ANDB 1,X
+* ANDA 0,X
+* JMP STABX
+*
+* ======>> 21 <<
+* ( n1 n2 --- n )
+* Bitwise or the top two integers.
+ FCB $82
+ FCC 'O' ; 'OR'
+ FCB $D2
+ FDB AND-6
+OR FDB *+NATWID
+ PULU A,B
+ ORB 1,U
+ ORA ,U
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* ORB 1,X
+* ORA 0,X
+* JMP STABX
+*
+* ======>> 22 <<
+* ( n1 n2 --- n )
+* Bitwise exclusive or the top two integers.
+ FCB $83
+ FCC 'XO' ; 'XOR'
+ FCB $D2
+ FDB OR-5
+XOR FDB *+NATWID
+ PULU A,B
+ EORB 1,U
+ EORA ,U
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* EORB 1,X
+* EORA 0,X
+* JMP STABX
+*
+* ######>> screen 26 <<
+* ======>> 23 <<
+* ( --- adr )
+* Fetch the parameter stack pointer (before it is pushed).
+* This points at whatever was on the top of stack before.
+ FCB $83
+ FCC 'SP' ; 'SP@'
+ FCB $C0
+ FDB XOR-6
+SPAT FDB *+NATWID
+ TFR U,X
+ PSHU X
+ RTS
+* TFR S,X ; TSX :
+* STX N scratch area
+* LDX #N
+* JMP GETX
+*
+* ======>> 24 <<
+* ( whatever --- nothing )
+* Initialize the parameter stack pointer from the USER variable S0.
+* Effectively clears the stack.
+ FCB $83
+ FCC 'SP' ; 'SP!'
+ FCB $A1
+ FDB SPAT-6
+SPSTOR FDB *+NATWID
+ LDU <XSPZER
+ RTS
+* LDX UP
+* LDX XSPZER-UORIG,X
+* TFR X,S ; TXS : watch it ! X and S are not equal on 6800.
+* JMP NEXT
+* ======>> 25 <<
+* ( whatever *** nothing )
+* Initialize the return stack pointer from the initialization table
+* instead of the user variable R0, for some reason.
+* Quite possibly, this should be from R0.
+* Effectively aborts all in process definitions, except the active one.
+* An emergency measure, to be sure.
+* The routine that calls this must never execute a return.
+* So this should never be executed from the terminal, I guess.
+* This is another that should be compile-time only, and in a separate vocabulary.
+ FCB $83
+ FCC 'RP' ; 'RP!'
+ FCB $A1
+ FDB SPSTOR-6
+RPSTOR FDB *+NATWID
+ PULS X ; But this guy has to return to his caller.
+ LDS RINIT
+ JMP ,X
+* LDX RINIT initialize from rom constant
+* STX RP
+* JMP NEXT
+*
+* ======>> 26 <<
+* ( ip *** )
+* Pop IP from return stack (return from high-level definition).
+* Can be used in a screen to force interpretion to terminate.
+* Must not be executed when temporaries are saved on top of the return stack.
+ FCB $82
+ FCC ';' ; ';S'
+ FCB $D3
+ FDB RPSTOR-6
+SEMIS FDB *+NATWID
+ PULS D,Y ; return address in D, and saved IP in Y.
+ TFR D,PC ; Synthetic return.
+*
+* Form 6800 model:
+* LDX RP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX RP
+* LDX 0,X get address we have just finished.
+* JMP NEXT+2 increment the return address & do next word
+*
+* ######>> screen 27 <<
+* ======>> 27 <<
+* ( limit index *** index index )
+* Force the terminating condition for the innermost loop by
+* copying its index to its limit.
+* Termination is postponed until the next
+* LOOP or +LOOP instruction is executed.
+* The index remains available for use until
+* the LOOP or +LOOP instruction is encountered.
+* Note that the assumption is that the current count is the correct count
+* to end at, rather than pushing the count to the final count.
+ FCB $85
+ FCC 'LEAV' ; 'LEAVE'
+ FCB $C5
+ FDB SEMIS-5
+LEAVE FDB *+NATWID
+ LDD NATWID,S ; Dodge the return address.
+ STD 2*NATWID,S
+ RTS
+* LDX RP
+* LDA 2,X
+* LDB 3,X
+* STA 4,X
+* STB 5,X
+* JMP NEXT
+*
+* ======>> 28 <<
+* ( n --- )
+* ( *** n )
+* Move top of parameter stack to top of return stack.
+ FCB $82
+ FCC '>' ; '>R'
+ FCB $D2
+ FDB LEAVE-8
+TOR FDB *+NATWID
+ PULU A,B
+ LDX ,S
+ STD ,S ; Put it where the return address was.
+ JMP ,X
+* LDX RP
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* PULS A ;
+* PULS B ;
+* STA 2,X
+* STB 3,X
+* JMP NEXT
+*
+* ======>> 29 <<
+* ( --- n )
+* ( n *** )
+* Move top of return stack to top of parameter stack.
+ FCB $82
+ FCC 'R' ; 'R>'
+ FCB $BE
+ FDB TOR-5
+FROMR FDB *+NATWID
+ PULS D,X
+ PSHU X
+ TFR D,PC
+* LDX RP
+* LDA 2,X
+* LDB 3,X
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX RP
+* JMP PUSHBA
+*
+* ======>> 30 <<
+* ( --- n )
+* ( n *** n )
+* Copy the top of return stack to top of parameter stack.
+* A synonym for I.
+ FCB $81 R
+ FCB $D2
+ FDB FROMR-5
+R FDB I+NATWID
+
+* LDX RP
+* LEAX 1,X ;
+* LEAX 1,X ;
+* JMP GETX
+*
+* ######>> screen 28 <<
+* ======>> 31 <<
+* ( n --- n=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 *+NATWID
+ LDD #0
+ LDX ,U
+ BNE ZEQUF
+ INCB ; 1 is true
+ZEQUF STD ,U
+ RTS
+* TFR S,X ; TSX :
+* CLRA ;
+* CLRB ;
+* LDX 0,X
+* BNE ZEQU2
+* INCB ;
+*ZEQU2 TFR S,X ; TSX :
+* JMP STABX
+*
+* ======>> 32 <<
+* ( n --- n<0 )
+* Flag true if top is negative (MSbit set), otherwise false.
+ FCB $82
+ FCC '0' ; '0<'
+ FCB $BC
+ FDB ZEQU-5
+ZLESS FDB *+NATWID
+ LDD #0
+ TST ,U
+ BPL ZLESSF
+ INCB
+ZLESSF STD ,U
+ RTS
+* TFR S,X ; TSX :
+* LDA #$80 check the sign bit
+* ANDA 0,X
+* BEQ ZLESS2
+* CLRA ; if neg.
+* LDB #1
+* JMP STABX
+* ZLESS2 CLRB ;
+* JMP STABX
+*
+* ######>> screen 29 <<
+* ======>> 33 <<
+* ( n1 n2 --- n1+n2 )
+* Add top two words.
+ FCB $81 '+'
+ FCB $AB
+ FDB ZLESS-5
+PLUS FDB *+NATWID
+ PULU A,B ; #2~7
+ ADDD ,U ; #2~6
+ STD ,U ; #2~5
+ RTS ; #1~5 =#7~23
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* ADDB 1,X
+* ADCA 0,X
+* JMP STABX
+*
+* ======>> 34 <<
+* ( d1 d2 --- d1+d2 )
+* Add top two double integers.
+ FCB $82
+ FCC 'D' ; 'D+'
+ FCB $AB
+ FDB PLUS-4
+DPLUS FDB *+NATWID
+ LDD 3*NATWID,U
+ ADDD NATWID,U
+ STD 3*NATWID,U
+ LDD 2*NATWID,U
+ ADCB 1,U
+ ADCA ,U
+ LEAU 2*NATWID,U
+ STD ,U
+ RTS
+* TFR S,X ; TSX :
+* ANDCC #~$01 ; CLC :
+* LDB #4
+* DPLUS2 LDA 3,X
+* ADCA 7,X
+* STA 7,X
+* LEAX -1,X ;
+* DECB ;
+* BNE DPLUS2
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP NEXT
+*
+* ======>> 35 <<
+* ( n --- -n )
+* Negate (two's complement) top of stack.
+ FCB $85
+ FCC 'MINU' ; 'MINUS'
+ FCB $D3
+ FDB DPLUS-5
+MINUS FDB *+NATWID
+ LDD #0 ; #3~3
+ SUBD ,U ; #2~5
+ STD ,U ; #2~5
+ RTS ; #1~5 = #8~18
+*
+* from 6800 model code:
+* TFR S,X ; TSX :
+* NEG 1,X
+* BCC MINUS2
+* NEG 0,X
+* BRA MINUS3
+* MINUS2 COM 0,X
+* MINUS3 JMP NEXT
+*
+* ======>> 36 <<
+* ( d --- -d )
+* Negate (two's complement) top two words on stack as a double integer.
+ FCB $86
+ FCC 'DMINU' ; 'DMINUS'
+ FCB $D3
+ FDB MINUS-8
+DMINUS FDB *+NATWID
+ LDD #0 ; #3~3
+ SUBD NATWID,U ; #2~7
+ STD NATWID,U ; #2~7
+ LDD #0 ; #3~3
+ SBCB 1,U ; #2~5
+ SBCA ,U ; #2~4
+ STD ,U ; #2~5
+ RTS ; #1~5 = #17~39
+* TFR S,X ; TSX :
+* COM 0,X
+* COM 1,X
+* COM 2,X
+* NEG 3,X
+* BNE DMINX
+* INC 2,X
+* BNE DMINX
+* INC 1,X
+* BNE DMINX
+* INC 0,X
+* DMINX JMP NEXT
+*
+* ######>> screen 30 <<
+* ======>> 37 <<
+* ( n1 n2 --- n1 n2 n1 )
+* Push a copy of the second word on stack.
+ FCB $84
+ FCC 'OVE' ; 'OVER'
+ FCB $D2
+ FDB DMINUS-9
+OVER FDB *+NATWID
+ LDD NATWID,U
+ PSHU D
+ RTS
+* TFR S,X ; TSX :
+* LDA 2,X
+* LDB 3,X
+* JMP PUSHBA
+*
+* ======>> 38 <<
+* ( n --- )
+* Discard the top word on stack.
+ FCB $84
+ FCC 'DRO' ; 'DROP'
+ FCB $D0
+ FDB OVER-7
+DROP FDB *+NATWID
+ LEAU NATWID,U
+ RTS
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP NEXT
+*
+* ======>> 39 <<
+* ( n1 n2 --- n2 n1 )
+* Swap the top two words on stack.
+ FCB $84
+ FCC 'SWA' ; 'SWAP'
+ FCB $D0
+ FDB DROP-7
+SWAP FDB *+NATWID
+ PULU D,X
+ PSHU D
+ PSHU X
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* LDX 0,X
+* LEAS 1,S ;
+* LEAS 1,S ;
+* PSHS B ;
+* PSHS A ;
+* STX N
+* LDX #N
+* JMP GETX
+*
+* ======>> 40 <<
+* ( n1 --- n1 n1 )
+* Push a copy of the top word on stack.
+ FCB $83
+ FCC 'DU' ; 'DUP'
+ FCB $D0
+ FDB SWAP-7
+DUP FDB *+NATWID
+ LDD ,U
+ PSHU D
+ RTS
+* PULS A ;
+* PULS B ;
+* PSHS B ;
+* PSHS A ;
+* JMP PUSHBA
+*
+* ######>> screen 31 <<
+* ======>> 41 <<
+* ( n adr --- )
+* Add the second word on stack to the word at the adr on top of stack.
+ FCB $82
+ FCC '+' ; '+!'
+ FCB $A1
+ FDB DUP-6
+PSTORE FDB *+NATWID
+ PULU X
+ LDD ,X
+ ADDD ,U++
+ STD ,X
+ RTS
+* TFR S,X ; TSX :
+* LDX 0,X
+* LEAS 1,S ;
+* LEAS 1,S ;
+* PULS A ; get stack data
+* PULS B ;
+* ADDB 1,X add & store low byte
+* STB 1,X
+* ADCA 0,X add & store hi byte
+* STA 0,X
+* JMP NEXT
+*
+* ======>> 42 <<
+* ( adr b --- )
+* Exclusive or byte at adr with low byte of top word.
+ FCB $86
+ FCC 'TOGGL' ; 'TOGGLE'
+ FCB $C5
+ FDB PSTORE-5
+TOGGLE FDB *+NATWID
+ PULU D,X
+ EORB ,X
+ STB ,X
+ RTS
+* Using the model code would be less likely to introduce bugs,
+* but that would sort-of defeat my purposes here.
+* Anyway, I can borrow from theoretically known good bif-6809 code
+* and it's fewer bytes and much faster code this way.
+* TOGGLE
+* FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
+* FDB SEMIS
+*
+* ######>> screen 32 <<
+* ======>> 43 <<
+* ( adr --- n )
+* Replace address on stack with the word at the address.
+ FCB $81 @
+ FCB $C0
+ FDB TOGGLE-9
+AT FDB *+NATWID
+ LDD [,U]
+ STD ,U
+ RTS
+* TFR S,X ; TSX :
+* LDX 0,X get address
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP GETX
+*
+* ======>> 44 <<
+* ( adr --- b )
+* Replace address on top of stack with the byte at the address.
+* High byte of result is clear.
+ FCB $82
+ FCC 'C' ; 'C@'
+ FCB $C0
+ FDB AT-4
+CAT FDB *+NATWID
+ LDB [,U]
+ CLRA
+ STD ,U
+ RTS
+
+
+* TFR S,X ; TSX :
+* LDX 0,X
+* CLRA ;
+* LDB 0,X
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP PUSHBA
+*
+* ======>> 45 <<
+* ( n adr --- )
+* Store second word on stack at address on top of stack.
+ FCB $81
+ FCB $A1
+ FDB CAT-5
+STORE FDB *+NATWID
+ LDD NATWID,U
+ STD [,U]
+ LEAU 2*NATWID,U
+ RTS
+* TFR S,X ; TSX :
+* LDX 0,X get address
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP PULABX
+*
+* ======>> 46 <<
+* ( b adr --- )
+* Store low byte of second word on stack at address on top of stack.
+* High byte is ignored.
+ FCB $82
+ FCC 'C' ; 'C!'
+ FCB $A1
+ FDB STORE-4
+CSTORE FDB *+NATWID
+ LDB 3,U
+ STB [,U]
+ LEAU 2*NATWID,U
+ RTS
+* TFR S,X ; TSX :
+* LDX 0,X get address
+* LEAS 1,S ;
+* LEAS 1,S ;
+* LEAS 1,S ;
+* PULS B ;
+* STB 0,X
+* JMP NEXT
+ PAGE
+*
+* ######>> screen 33 <<
+* ======>> 47 <<
+* ( --- ) P
+* { : name sundry-activities ; } typical input
+* If executing (not compiling),
+* record the data stack mark in CSP,
+* Set the CONTEXT vocabulary to CURRENT,
+* CREATE a header,
+* set state to compile,
+* and compile the call to the trailing native CPU machine code DOCOL.
+*
+* This would not be hard to flatten to native code.
+* But that's not the purpose of a model.
+ FCB $C1 : immediate
+ FCB $BA
+ FDB CSTORE-5
+COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
+ FDB CREATE,RBRAK
+ FDB PSCODE
+
+* Here is the IP pusher for allowing
+* nested words in the virtual machine:
+* ( ;S is the equivalent un-nester )
+
+* ( *** oldIP )
+* Characteristic of a colon (:) definition.
+* Begins execution of a high-level definition,
+* i. e., nests the definition and begins processing icodes.
+* Mechanically, it pushes the IP (Y register)
+* and loads the Parameter Field Address of the definition which
+* called it into the IP.
+DOCOL LDD ,S ; Save the return address.
+ STY ,S ; Nest the old IP.
+ LEAY NATWID,X ; W still in X, bump to parameters, load as new IP.
+ TFR D,PC ; synthetic return to interpret.
+
+* DOCOL LDX RP make room in the stack
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* LDA IP
+* LDB IP+1
+* STA 2,X Store address of the high level word
+* STB 3,X that we are starting to execute
+* LDX W Get first sub-word of that definition
+* JMP NEXT+2 and execute it
+*
+* ======>> 48 <<
+* ( --- ) P
+* { : name sundry-activities ; } typical input
+* ERROR check data stack against mark in CSP,
+* compile ;S,
+* unSMUDGE LATEST definition,
+* and set state to interpretation.
+ FCB $C1 ; imnediate code
+ FCB $BB
+ FDB COLON-4
+SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
+ FDB SEMIS
+*
+* ######>> screen 34 <<
+* ======>> 49 <<
+* ( n --- )
+* { value CONSTANT name } typical input
+* CREATE a header,
+* unSMUDGE it,
+* compile the constant value,
+* and compile the call to the trailing native CPU machine code DOCON.
+ FCB $88
+ FCC 'CONSTAN' ; 'CONSTANT'
+ FCB $D4
+ FDB SEMI-4
+CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
+* ( --- n )
+* Characteristic of a CONSTANT.
+* A CONSTANT simply loads its value from its parameter field
+* and pushes it on the stack.
+DOCON LDD NATWID,X ; Get the first natural width word of the parameter field.
+ PSHU D
+ RTS
+* DOCON LDX W
+* LDA 2,X
+* LDB 3,X A & B now contain the constant
+* JMP PUSHBA
+*
+* Not in model, needed for abstraction:
+* ( --- NATWID )
+* The byte width of objects on stack.
+ FCB $86
+ FCC 'NATWI' ; 'NATWID'
+ FCB $C4
+ FDB CON-11
+NATWC FDB DOCON
+NATWCV FDB NATWID
+*
+* Not in model, needed for abstraction:
+* Note that this is not defined as an INCREMENTER!
+* Coded to increment by the exact constant returned by NATWID
+* ( n --- n+NATWID )
+ FCB $84
+ FCC 'NAT' ; 'NAT+'
+ FCB $AB
+ FDB NATWC-9
+NATP FDB *+NATWID
+ LDD ,U
+ ADDD NATWCV,PCR ; Looking ahead, does not have to be PCRelative.
+ STD ,U
+ RTS
+* How this might have been done for 6800 model:
+* CLRA ; We know the natural width is less than 255, LOL.
+* LDAB NATWCV+1
+* TSX
+* ADDB 1,X
+* ADCA ,X
+* JMP STABX
+*
+* ======>> 50 <<
+* ( init --- )
+* { init VARIABLE name } typical input
+* Use CONSTANT to CREATE a header and compile the initial value, init,
+* then overwrite the characteristic to point to DOVAR.
+ FCB $88
+ FCC 'VARIABL' ; 'VARIABLE'
+ FCB $C5
+ FDB NATP-7
+VAR FDB DOCOL,CON,PSCODE
+* ( --- vadr )
+* Characteristic of a VARIABLE.
+* A VARIABLE pushes its PFA address on the stack.
+* The parameter field of a VARIABLE is the actual allocation of the variable,
+* so that pushing its address allows its contents to be @ed (fetched).
+* Ordinary arrays and strings that do not subscript themselves
+* may be allocated by defining a variable
+* and immediately ALLOTting the remaining needed space.
+* VARIABLES are global to all users,
+* and thus should be hidden in resource monitors, but aren't.
+DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters.
+ PSHU X
+ RTS
+* DOVAR LDA W
+* LDB W+1
+* ADDB #2
+* ADCA #0 A,B now contain the address of the variable
+* JMP PUSHBA
+*
+* ======>> 51 <<
+* ( ub --- )
+* { uboffset USER name } typical input
+* CREATE a header and compile the unsigned byte offset in the per-USER table,
+* then overwrite the header with a call to DOUSER.
+* The USER is entirely responsible for maintaining allocation!
+ FCB $84
+ FCC 'USE' ; 'USER'
+ FCB $D2
+ FDB VAR-11
+USER FDB DOCOL,CON,PSCODE
+* ( --- vadr )
+* Characteristic of a per-USER variable.
+* USER variables are similiar to VARIABLEs,
+* but are allocated (by hand!) in the per-user table.
+* A USER variable's parameter field contains its offset in the per-user table.
+DOUSER TFR DP,A ; Make a pointer to the direct page.
+ CLRB
+* See Alternative -- alternatives start from this point.
+ ADDD NATWID,X ; Add it to the offset to the per-user variable.
+ PSHU D
+ TFR D,X ; Cache the pointer in X for the caller.
+ RTS
+* Hey, the per-user table could actually be larger than 256 bytes!
+* But we knew that. It's just not as esthetic to calculate it this way.
+* Alternative A:
+* LDX NATWID,X ; Keep the offset
+* EXG D,X ; Prepare for EA
+* LEAX D,X
+* PSHU X
+* RTS
+* Alternative B:
+* PSHS Y ; Get Y free for calculations.
+* TFR D,Y ; Y points to the UP base
+* LDD NATWID,X ; Get the offset
+* LEAX D,Y ; Leave the pointer cached in X.
+* PSHU X
+* PULS Y,PC
+*
+* From the 6800 model:
+* DOUSER LDX W get offset into user's table
+* LDA 2,X
+* LDB 3,X
+* ADDB UP+1 add to users base address
+* ADCA UP
+* JMP PUSHBA push address of user's variable
+*
+* ######>> screen 35 <<
+* ======>> 52 <<
+* ( --- 0 )
+ FCB $81
+ FCB $B0 0
+ FDB USER-7
+ZERO FDB DOCON
+ FDB 0000
+*
+* ======>> 53 <<
+* ( --- 1 )
+ FCB $81
+ FCB $B1 1
+ FDB ZERO-4
+ONE FDB DOCON
+ONEV FDB 1
+*
+* ======>> 54 <<
+* ( --- 2 )
+ FCB $81
+ FCB $B2 2
+ FDB ONE-4
+TWO FDB DOCON
+TWOV FDB 2
+*
+* ======>> 55 <<
+* ( --- 3 )
+ FCB $81
+ FCB $B3 3
+ FDB TWO-4
+THREE FDB DOCON
+ FDB 3
+*
+* ======>> 56 <<
+* ( --- SP )
+* ASCII SPACE character
+ FCB $82
+ FCC 'B' ; 'BL'
+ FCB $CC
+ FDB THREE-4
+BL FDB DOCON ascii blank
+ FDB $20
+*
+* ======>> 57 <<
+* This really shouldn't be a CONSTANT.
+* ( --- adr )
+* The base of the disk buffer space.
+ FCB $85
+ FCC 'FIRS' ; 'FIRST'
+ FCB $D4
+ FDB BL-5
+FIRST FDB DOCON
+ FDB BUFBAS
+* FDB MEMEND-528 (132 * NBLK)
+*
+* ======>> 58 <<
+* This really shouldn't be a CONSTANT.
+* ( --- adr )
+* The limit of the disk buffer space.
+ FCB $85
+ FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
+ FCB $D4
+ FDB FIRST-8
+LIMIT FDB DOCON
+ FDB BUFBAS+BUFSZ
+* In 6800 model, was
+* FDB MEMEND
+*
+* ======>> 59 <<
+* ( --- sectorsize )
+* The size, in bytes, of a buffer.
+ FCB $85
+ FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
+ FCB $C6
+ FDB LIMIT-8
+BBUF FDB DOCON
+ FDB SECTSZ
+* Hardcoded in 6800 model:
+* FDB 128
+*
+* ======>> 60 <<
+* ( --- blocksperscreen )
+* The size, in blocks, of a screen.
+* Should this be the same as NBLK, the number of block buffers maintained?
+ FCB $85
+ FCC 'B/SC' ; 'B/SCR' : (blocks/screen)
+ FCB $D2
+ FDB BBUF-8
+BSCR FDB DOCON
+ FDB SCRSZ/SECTSZ
+* Hardcoded in 6800 model as:
+* FDB 8
+* blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
+*
+* ======>> 61 <<
+* ( n --- adr )
+* Calculate the address of entry (#n/2) in the boot-up parameter table.
+* (Adds the base of the boot-up table to n.)
+ FCB $87
+ FCC '+ORIGI' ; '+ORIGIN'
+ FCB $CE
+ FDB BSCR-8
+PORIG FDB DOCOL,LIT,ORIG,PLUS
+ FDB SEMIS
+*
+* ######>> screen 36 <<
+* ======>> 62 <<
+* ( n --- adr )
+* This is the per-task variable recording the initial parameter stack pointer.
+ FCB $82
+ FCC 'S' ; 'S0'
+ FCB $B0
+ FDB PORIG-10
+SZERO FDB DOUSER
+ FDB XSPZER-UORIG
+*
+* ======>> 63 <<
+* ( n --- adr )
+* This is the per-task variable recording the initial return stack pointer.
+ FCB $82
+ FCC 'R' ; 'R0'
+ FCB $B0
+ FDB SZERO-5
+RZERO FDB DOUSER
+ FDB XRZERO-UORIG
+*
+* ======>> 64 <<
+* ( --- vadr )
+* Terminal Input Buffer address.
+* Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
+ FCB $83
+ FCC 'TI' ; 'TIB'
+ FCB $C2
+ FDB RZERO-5
+TIB FDB DOUSER
+ FDB XTIB-UORIG
+*
+* ======>> 65 <<
+* ( --- maxnamewidth )
+* This is the maximum width to which symbol names will be recorded.
+ FCB $85
+ FCC 'WIDT' ; 'WIDTH'
+ FCB $C8
+ FDB TIB-6
+WIDTH FDB DOUSER
+ FDB XWIDTH-UORIG
+*
+* ======>> 66 <<
+* ( --- vadr )
+* Availability of error messages on disk.
+* Contains 1 if messages available,
+* 0 if not,
+* -1 if a disk error has occurred.
+ FCB $87
+ FCC 'WARNIN' ; 'WARNING'
+ FCB $C7
+ FDB WIDTH-8
+WARN FDB DOUSER
+ FDB XWARN-UORIG
+*
+* ======>> 67 <<
+* ( --- vadr )
+* Boundary for FORGET.
+ FCB $85
+ FCC 'FENC' ; 'FENCE'
+ FCB $C5
+ FDB WARN-10
+FENCE FDB DOUSER
+ FDB XFENCE-UORIG
+*
+* ======>> 68 <<
+* ( --- vadr )
+* Dictionary pointer, fetched by HERE.
+ FCB $82
+ FCC 'D' ; 'DP' : points to first free byte at end of dictionary
+ FCB $D0
+ FDB FENCE-8
+DICTPT FDB DOUSER
+ FDB XDICTP-UORIG
+*
+* ======>> 68.5 <<
+* ( --- vadr ) ******* Need to check what this is!
+* Used in maintaining vocabularies.
+* I think it points to the "parent" vocabulary, but I'm not sure.
+* Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
+ FCB $88
+ FCC 'VOC-LIN' ; 'VOC-LINK'
+ FCB $CB
+ FDB DICTPT-5
+VOCLIN FDB DOUSER
+ FDB XVOCL-UORIG
+*
+* ======>> 69 <<
+* ( --- vadr )
+* Disk block being interpreted.
+* Zero refers to terminal.
+* ******** Should be made a 32 bit user variable! ********
+* But the base system needs to have full 32 bit support, div and mul, etc.
+* before we can do that.
+ FCB $83
+ FCC 'BL' ; 'BLK'
+ FCB $CB
+ FDB VOCLIN-11
+BLK FDB DOUSER
+ FDB XBLK-UORIG
+*
+* ======>> 70 <<
+* ( --- vadr )
+* Input buffer offset/cursor.
+ FCB $82
+ FCC 'I' ; 'IN' : scan pointer for input line buffer
+ FCB $CE
+ FDB BLK-6
+IN FDB DOUSER
+ FDB XIN-UORIG
+*
+* ======>> 71 <<
+* ( --- vadr )
+* Output buffer offset/cursor.
+ FCB $83
+ FCC 'OU' ; 'OUT'
+ FCB $D4
+ FDB IN-5
+OUT FDB DOUSER
+ FDB XOUT-UORIG
+*
+* ======>> 72 <<
+* ( --- vadr )
+* Screen currently being edited, once we have an editor running.
+ FCB $83
+ FCC 'SC' ; 'SCR'
+ FCB $D2
+ FDB OUT-6
+SCR FDB DOUSER
+ FDB XSCR-UORIG
+* ######>> screen 37 <<
+*
+* ======>> 73 <<
+* ( --- vadr )
+* Sector offset for LOADing screens,
+* set by DRIVE to make a new drive the default.
+* This should also be 32 bit or bigger.
+ FCB $86
+ FCC 'OFFSE' ; 'OFFSET'
+ FCB $D4
+ FDB SCR-6
+OFSET FDB DOUSER
+ FDB XOFSET-UORIG
+*
+* ======>> 74 <<
+* ( --- vadr )
+* Current context of interpretation (vocabulary root).
+ FCB $87
+ FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
+ FCB $D4
+ FDB OFSET-9
+CONTXT FDB DOUSER
+ FDB XCONT-UORIG
+*
+* ======>> 75 <<
+* ( --- vadr )
+* Current context of definition (vocabulary root).
+ FCB $87
+ FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
+ FCB $D4
+ FDB CONTXT-10
+CURENT FDB DOUSER
+ FDB XCURR-UORIG
+*
+* ======>> 76 <<
+* ( --- vadr )
+* Compiler/interpreter state.
+ FCB $85
+ FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
+ FCB $C5
+ FDB CURENT-10
+STATE FDB DOUSER
+ FDB XSTATE-UORIG
+*
+* ======>> 77 <<
+* ( --- vadr )
+* Numeric conversion base.
+ FCB $84
+ FCC 'BAS' ; 'BASE' : number base for all input & output
+ FCB $C5
+ FDB STATE-8
+BASE FDB DOUSER
+ FDB XBASE-UORIG
+*
+* ======>> 78 <<
+* ( --- vadr )
+* Decimal point location for output.
+ FCB $83
+ FCC 'DP' ; 'DPL'
+ FCB $CC
+ FDB BASE-7
+DPL FDB DOUSER
+ FDB XDPL-UORIG
+*
+* ======>> 79 <<
+* ( --- vadr )
+* Field width for I/O formatting.
+ FCB $83
+ FCC 'FL' ; 'FLD'
+ FCB $C4
+ FDB DPL-6
+FLD FDB DOUSER
+ FDB XFLD-UORIG
+*
+* ======>> 80 <<
+* ( --- vadr )
+* Compiler stack mark for stack check.
+ FCB $83
+ FCC 'CS' ; 'CSP'
+ FCB $D0
+ FDB FLD-6
+CSP FDB DOUSER
+ FDB XCSP-UORIG
+*
+* ======>> 81 <<
+* ( --- vadr )
+* Editing cursor location.
+ FCB $82
+ FCC 'R' ; 'R#'
+ FCB $A3
+ FDB CSP-6
+RNUM FDB DOUSER
+ FDB XRNUM-UORIG
+*
+* ======>> 82 <<
+* ( --- vadr )
+* Pointer to last HELD character in PAD.
+ FCB $83
+ FCC 'HL' ; 'HLD'
+ FCB $C4
+ FDB RNUM-5
+HLD FDB DOCON
+ FDB XHLD
+*
+* ======>> 82.5 <<== SPECIAL
+* ( --- vadr )
+* Line width of active terminal.
+ FCB $87
+ FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
+ FCB $D3
+ FDB HLD-6
+COLUMS FDB DOUSER
+ FDB XCOLUM-UORIG
+*
+* ######>> screen 38 <<
+**
+** An INCREMENTER probably should not be defined without a defined CONSTANT?
+**
+** Make an INCREMENTER compiling word (not in model):
+** ( n --- )
+** { n INCREMENTER name } typical input
+** CREATE a header and compile the increment constant,
+** then overwrite the header with a call to DOINC.
+* FCB $8B
+* FCC 'INCREMENTE' ; 'INCREMENTER'
+* FCB $D2
+* FDB COLUMS-10
+* INCR FDB DOCOL,CON,PSCODE
+** ( n --- ninc )
+** Characteristic of an INCREMENTER.
+** This is too naive:
+* DOINC LDD ,U
+* ADDD NATWID,X ; Add the increment.
+* STD ,U
+* RTS
+* Compiling word should check that it is compiling a CONSTANT.
+*
+* ======>> 83 <<
+* ( n --- n+1 )
+ FCB $82
+ FCC '1' ; '1+'
+ FCB $AB
+ FDB COLUMS-10
+* Using the model keeps things semantically connected for other processors:
+ONEP FDB DOCOL,ONE,PLUS
+ FDB SEMIS
+** Greedy alternative:
+* ONEP FDB *+NATWID
+* LDD ,U
+* ADDD ONEV,PCR
+* STD ,U
+* RTS
+* Naive alternative:
+* ONEP FDB DOINC
+* FDB 1
+* Naive alternative:
+* ONEP FDB *+NATWID
+* LDD ,U
+* ADDD #1 ; It's hard to imagine 1+ being other than 1.
+* STD ,U
+* RTS
+*
+* ======>> 84 <<
+* ( n --- n+2 )
+ FCB $82
+ FCC '2' ; '2+'
+ FCB $AB
+ FDB ONEP-5
+* Using the model keeps things semantically connected for other processors:
+TWOP FDB DOCOL,TWO,PLUS
+ FDB SEMIS
+** Greedy alternative:
+* TWOP FDB *+NATWID
+* LDD ,U
+* ADDD TWOV,PCR ; See NAT+ (NATP)
+* STD ,U
+* RTS
+* Naive alternative:
+* TWOP FDB DOINC
+* FDB 2
+* Naive alternative:
+* TWOP FDB *+NATWID
+* LDD ,U
+* ADDD #2 ; See NAT+ (NATP)
+* STD ,U
+* RTS
+*
+* ======>> 85 <<
+* ( --- adr )
+* Get the DICTPT allocation, like a USER constant.
+* Should check the stack and heap for collision.
+ FCB $84
+ FCC 'HER' ; 'HERE'
+ FCB $C5
+ FDB TWOP-5
+HERE FDB DOCOL,DICTPT,AT
+ FDB SEMIS
+*
+* ======>> 86 <<
+* ( n --- )
+* Increase/decrease heap (add n to DP),
+* Should ERROR check stack/heap.
+ FCB $85
+ FCC 'ALLO' ; 'ALLOT'
+ FCB $D4
+ FDB HERE-7
+ALLOT FDB DOCOL,DICTPT,PSTORE
+ FDB SEMIS
+*
+* ======>> 87 <<
+* ( n --- )
+* Store word n at DP++,
+* Should ERROR check stack/heap.
+ FCB $81 ; , (COMMA)
+ FCB $AC
+ FDB ALLOT-8
+COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT
+ FDB SEMIS
+* COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
+* FDB SEMIS
+*
+* ======>> 88 <<
+* ( b --- )
+* Store byte b at DP+,
+* Should ERROR check stack/heap.
+ FCB $82
+ FCC 'C' ; 'C,'
+ FCB $AC
+ FDB COMMA-4
+CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
+ FDB SEMIS
+*
+* ======>> 89 <<
+* ( n1 n2 --- n1-n2 )
+* Subtract top two words.
+ FCB $81 ; -
+ FCB $AD
+ FDB CCOMM-5
+SUB FDB *+NATWID
+ LDD NATWID,U ; #2~6
+ SUBD ,U++ ; #2~9
+ STD ,U ; #2~5
+ RTS ; #1~5 = #7~25
+* SUB FDB DOCOL,MINUS,PLUS
+* FDB SEMIS ; Costs 6 bytes and lots of cycles.
+*
+* ======>> 90 <<
+* ( n1 n2 --- n1==n2 )
+* Return flag true if n1 and n2 are equal, otherwise false.
+ FCB $81 =
+ FCB $BD
+ FDB SUB-4
+EQUAL FDB DOCOL,SUB,ZEQU
+ FDB SEMIS
+*
+* ======>> 91 <<
+* ( n1 n2 --- n1<n2 )
+* Return flag true if n1 is less than n2, otherwise false.
+ FCB $81 <
+ FCB $BC
+ FDB EQUAL-4
+LESS FDB *+NATWID
+ LDD NATWID,U
+ SUBD ,U++
+ BGE FALSE
+TRUE LDD #1
+ STD ,U
+ RTS
+FALSE LDD #0
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* CMPA 0,X
+* LEAS 1,S ;
+* BGT LESST
+* BNE LESSF
+* CMPB 1,X ; Why not sub, sbc, bge?
+* BHI LESST
+* LESSF CLRB ;
+* BRA LESSX
+* LESST LDB #1
+* LESSX CLRA ;
+* LEAS 1,S ;
+* JMP PUSHBA
+*
+* ======>> 92 <<
+* ( n1 n2 --- n1>n2 )
+* Return flag true if n1 is greater than n2, false otherwise.
+ FCB $81 >
+ FCB $BE
+ FDB LESS-4
+GREAT FDB DOCOL,SWAP,LESS
+ FDB SEMIS
+*
+* ======>> 93 <<
+* ( n1 n2 n3 --- n2 n3 n1 )
+* Rotate the top three words on stack,
+* bringing the third word to the top.
+ FCB $83
+ FCC 'RO' ; 'ROT'
+ FCB $D4
+ FDB GREAT-4
+ROT FDB *+NATWID
+ PSHS Y
+ PULU D,X,Y
+ PSHU D,X
+ PSHU Y
+ PULS Y,PC
+* ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
+* FDB SEMIS
+*
+* ======>> 94 <<
+* ( --- )
+* EMIT a SPACE.
+ FCB $85
+ FCC 'SPAC' ; 'SPACE'
+ FCB $C5
+ FDB ROT-6
+SPACE FDB DOCOL,BL,EMIT
+ FDB SEMIS
+*
+* ======>> 95 <<
+* ( n0 n1 --- min(n0,n1) )
+* Leave the minimum of the top two integers.
+* Being too greedy here, but, whatever.
+ FCB $83
+ FCC 'MI' ; 'MIN'
+ FCB $CE
+ FDB SPACE-8
+MIN FDB *+NATWID
+ PULU D
+ CMPD ,U
+ BLE MINX
+ STD ,U
+MINX RTS
+* MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
+* FDB MIN2-*-NATWID
+* FDB SWAP
+* MIN2 FDB DROP
+* FDB SEMIS
+*
+* ======>> 96 <<
+* ( n0 n1 --- max(n0,n1) )
+* Leave the maximum of the top two integers.
+* Really should leave this as in the model.
+ FCB $83
+ FCC 'MA' ; 'MAX'
+ FCB $D8
+ FDB MIN-6
+MAX FDB *+NATWID
+ PULU D
+ CMPD ,U
+ BLE MAXX
+ STD ,U
+MAXX RTS
+* MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
+* FDB MAX2-*-NATWID
+* FDB SWAP
+* MAX2 FDB DROP
+* FDB SEMIS
+*
+* ======>> 97 <<
+* ( 0 --- 0 )
+* ( n --- n n )
+* DUP if non-zero.
+ FCB $84
+ FCC '-DU' ; '-DUP'
+ FCB $D0
+ FDB MAX-6
+DDUP FDB *+NATWID
+ LDD ,U
+ BEQ DDUPX
+ PSHU D
+DDUPX RTS
+* DDUP FDB DOCOL,DUP,ZBRAN
+* FDB DDUP2-*-NATWID
+* FDB DUP
+* DDUP2 FDB SEMIS
+*
+* ######>> screen 39 <<
+* ======>> 98.1 <<
+* Supplemental:
+* ( n<0 --- -1 )
+* ( n>=~ --- 1 )
+* Change top integer to its sign.
+ FCB $86
+ FCC 'SIGNU' ; 'SIGNUM'
+ FCB $CD
+ FDB DDUP-7
+SIGNUM FDB *+NATWID
+SIGNUE LDB #1
+ LDA ,U
+ BPL SIGNUP
+ NEGB
+SIGNUP SEX ; Couldn't they have called SignEXtend EXT instead?
+ STD ,U ; Am I too much of a prude?
+ RTS
+* 6800 model version should be something like this:
+* LDB #1
+* CLRA
+* TSX
+* TST ,X
+* BPL SIGNUP
+* NEGB
+* COMA
+* SIGNUP JMP STABX
+*
+* ======>> 98 <<
+* ( adr1 direction --- adr2 )
+* TRAVERSE the symbol name.
+* If direction is 1, find the end.
+* If direction is -1, find the beginning.
+ FCB $88
+ FCC 'TRAVERS' ; 'TRAVERSE'
+ FCB $C5
+ FDB SIGNUM-9
+TRAV FDB *+NATWID
+ BSR SIGNUE ; Convert negative to -, zero or positive to 1.
+ LDD ,U++ ; Still in D, but we have to pop it anyway.
+ LDX ,U ; If D is 1 or -1, so is B.
+ LDA #$7F
+TRAVLP LEAX B,X ; Don't look at the one we start at.
+ CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL.
+ BCC TRAVLP
+TRAVDN STX ,U
+ RTS
+* Doing this in 6809 just because it can be done may be getting too greedy.
+* TRAV FDB DOCOL,SWAP
+* TRAV2 FDB OVER,PLUS,LIT8
+* FCB $7F
+* FDB OVER,CAT,LESS,ZBRAN
+* FDB TRAV2-*-NATWID
+* FDB SWAP,DROP
+* FDB SEMIS
+*
+* ======>> 99 <<
+* ( --- symptr )
+* Fetch CURRENT as a per-USER constant.
+ FCB $86
+ FCC 'LATES' ; 'LATEST'
+ FCB $D4
+ FDB TRAV-11
+LATEST FDB DOCOL,CURENT,AT,AT
+ FDB SEMIS
+* LATEST FDB *+NATWID
+* Getting too greedy:
+* Version 1:
+* TFR DP,A
+* CLRB
+* TFR D,X
+* LDD CURENT+NATWID,PCR
+* LDX [D,X]
+* PSHU X ; Leave the address in X.
+* RTS
+* Version 2:
+* LEAX CURENT,PCR
+* JSR [,X]
+* PULU X
+* LDX [,X]
+* PSHU X
+* RTS
+* Too greedy, too many smantic holes to fall through.
+* If the address at the CFA is made relative,
+* this is part of the code that would be affected
+* if it is in native CPU code.
+*
+* ======>> 100 <<
+* Wanted to do these as INCREMENTERs,
+* but I need to stick with the model as much as possible,
+* (mostly, LOL) adding code only to make the model more clear.
+* ( pfa --- lfa )
+* Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
+ FCB $83
+ FCC 'LF' ; 'LFA'
+ FCB $C1
+ FDB LATEST-9
+LFA FDB DOCOL,LIT8
+* FCB 4
+ FCB 2*NATWID
+ FDB SUB
+ FDB SEMIS
+*
+* ======>> 101 <<
+* ( pfa --- cfa )
+* Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
+ FCB $83
+ FCC 'CF' ; 'CFA'
+ FCB $C1
+ FDB LFA-6
+* CFA FDB DOCOL,TWO,SUB
+CFA FDB DOCOL,NATWC,SUB
+ FDB SEMIS
+*
+* ======>> 102 <<
+* ( pfa --- nfa )
+* Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
+ FCB $83
+ FCC 'NF' ; 'NFA'
+ FCB $C1
+ FDB CFA-6
+NFA FDB DOCOL,LIT8
+* FCB 5
+ FCB NATWID*2+1
+ FDB SUB,ONE,MINUS,TRAV
+ FDB SEMIS
+*
+* ======>> 103 <<
+* ( nfa --- pfa )
+* Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
+ FCB $83
+ FCC 'PF' ; 'PFA'
+ FCB $C1
+ FDB NFA-6
+PFA FDB DOCOL,ONE,TRAV,LIT8
+* FCB 5
+ FCB NATWID*2+1
+ FDB PLUS
+ FDB SEMIS
+*
+* ######>> screen 40 <<
+* ======>> 104 <<
+* ( --- )
+* Save the parameter stack pointer in CSP for compiler checks.
+ FCB $84
+ FCC '!CS' ; '!CSP'
+ FCB $D0
+ FDB PFA-6
+SCSP FDB DOCOL,SPAT,CSP,STORE
+ FDB SEMIS
+*
+* ======>> 105 <<
+* ( 0 n --- ) ( *** )
+* ( true n --- IN BLK ) ( anything *** nothing )
+* If flag is false, do nothing.
+* If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
+* Leaves cursor position (IN)
+* and currently loading block number (BLK) on stack, for analysis.
+*
+* This one is too important to be high-level Forth codes.
+* When we have an error, we want to disturb as little as possible.
+* But fixing that cascades through ERROR and MESSAGE
+* into the disk block system.
+* And we aren't ready for that yet.
+ FCB $86
+ FCC '?ERRO' ; '?ERROR'
+ FCB $D2
+ FDB SCSP-7
+* QERR FDB *+NATWID
+* LDD NATWID,U
+* BNE QERROR
+* LEAU 2*NATWID,U
+* RTS
+** this doesn't work anyway: QERROR LBR ERROR
+QERR FDB DOCOL,SWAP,ZBRAN
+ FDB QERR2-*-NATWID
+ FDB ERROR,BRAN
+ FDB QERR3-*-NATWID
+QERR2 FDB DROP
+QERR3 FDB SEMIS
+*
+* ======>> 106 <<
+* STATE is compiling:
+* ( --- ) ( *** )
+* STATE is compiling:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not compiling.
+ FCB $85
+ FCC '?COM' ; '?COMP'
+ FCB $D0
+ FDB QERR-9
+QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8
+ FCB $11
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 107 <<
+* STATE is executing:
+* ( --- ) ( *** )
+* STATE is executing:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not executing.
+ FCB $85
+ FCC '?EXE' ; '?EXEC'
+ FCB $C3
+ FDB QCOMP-8
+QEXEC FDB DOCOL,STATE,AT,LIT8
+ FCB $12
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 108 <<
+* ( n1 n1 --- ) ( *** )
+* ( n1 n2 --- IN BLK ) ( anything *** nothing )
+* ERROR if top two are unequal.
+* MESSAGE says compiled conditionals do not match.
+ FCB $86
+ FCC '?PAIR' ; '?PAIRS'
+ FCB $D3
+ FDB QEXEC-8
+QPAIRS FDB DOCOL,SUB,LIT8
+ FCB $13
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 109 <<
+* CSP and parameter stack are balanced (equal):
+* ( --- ) ( *** )
+* CSP and parameter stack are not balanced (unequal):
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if return/control stack is not at same level as last !CSP.
+* Usually indicates that a definition has been left incomplete.
+ FCB $84
+ FCC '?CS' ; '?CSP'
+ FCB $D0
+ FDB QPAIRS-9
+QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8
+ FCB $14
+ FDB QERR
+ FDB SEMIS
+*
+* ======>> 110 <<
+* Active BLK input:
+* ( --- ) ( *** )
+* No active BLK input:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not loading, i. e., if BLK is zero.
+ FCB $88
+ FCC '?LOADIN' ; '?LOADING'
+ FCB $C7
+ FDB QCSP-7
+QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8
+ FCB $16
+ FDB QERR
+ FDB SEMIS
+*
+* ######>> screen 41 <<
+* ======>> 111 <<
+* ( --- )
+* Compile an in-line literal value from the instruction stream.
+ FCB $87
+ FCC 'COMPIL' ; 'COMPILE'
+ FCB $C5
+ FDB QLOAD-11
+* COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
+* COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
+COMPIL FDB DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
+ FDB SEMIS
+*
+* ======>> 112 <<
+* ( --- ) P
+* Clear the compile state bit(s) (shift to interpret).
+ FCB $C1 [ immediate
+ FCB $DB
+ FDB COMPIL-10
+LBRAK FDB DOCOL,ZERO,STATE,STORE
+ FDB SEMIS
+*
+* ======>> 113 <<
+*
+STCOMP EQU $C0
+* ( --- )
+* Set the compile state bit(s) (shift to compile).
+ FCB $81 ]
+ FCB $DD
+ FDB LBRAK-4
+RBRAK FDB DOCOL,LIT8
+ FCB STCOMP
+ FDB STATE,STORE
+ FDB SEMIS
+*
+* ======>> 114 <<
+* ( --- )
+* Toggle SMUDGE bit of LATEST definition header,
+* to hide it until defined or reveal it after definition.
+ FCB $86
+ FCC 'SMUDG' ; 'SMUDGE'
+ FCB $C5
+ FDB RBRAK-4
+SMUDGE FDB DOCOL,LATEST,LIT8
+ FCB FSMUDG
+ FDB TOGGLE
+ FDB SEMIS
+*
+* ======>> 115 <<
+* ( --- )
+* Set the conversion base to sixteen (b00010000).
+ FCB $83
+ FCC 'HE' ; 'HEX'
+ FCB $D8
+ FDB SMUDGE-9
+HEX FDB DOCOL
+ FDB LIT8
+ FCB 16 ; decimal sixteen
+ FDB BASE,STORE
+ FDB SEMIS
+*
+* ======>> 116 <<
+* ( --- )
+* Set the conversion base to ten (b00001010).
+ FCB $87
+ FCC 'DECIMA' ; 'DECIMAL'
+ FCB $CC
+ FDB HEX-6
+DEC FDB DOCOL
+ FDB LIT8
+ FCB 10 ; decimal ten
+ FDB BASE,STORE
+ FDB SEMIS
+*
+* ######>> screen 42 <<
+* ======>> 117 <<
+* ( --- ) ( IP *** )
+* Pop the saved IP and use it to
+* compile the latest symbol as a reference to a ;CODE definition;
+* overwrite the code field of the symbol found by LATEST
+* with the address of the low-level characteristic code
+* provided in the defining definition.
+* Look closely at where things return, consider the operation of R> and >R .
+*
+* The machine-level code which follows (;CODE) in the instruction stream
+* is not executed by the defining symbol,
+* but becomes the characteristic of the defined symbol.
+* This is the usual way to generate the characteristics of VARIABLEs,
+* CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
+*
+* Finally, note that, if code shifts from low level back to high
+* (native CPU machine code calling into a list of FORTH codes),
+* the low level code can't just call a high-level definition.
+* Leaf definitions can directly call other leaf definitions,
+* but not non-leafs.
+* It will need an anonymous list, probably embedded in the low-level code,
+* and Y and X will have to be set appropriately before entering the list.
+ FCB $87
+ FCC '(;CODE' ; '(;CODE)'
+ FCB $A9
+ FDB DEC-10
+* PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
+PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+ FDB LATEST,PFA,CFA,STORE
+ FDB SEMIS
+*
+* ======>> 118 <<
+* ( --- ) P
+* ?CSP to see if there are loose ends in the defining definition
+* before shifting to the assembler,
+* compile (;CODE) in the defining definition's instruction stream,
+* shift to interpreting,
+* make the ASSEMBLER vocabulary current,
+* and !CSP to mark the stack
+* in preparation for assembling low-level code.
+* Note that ;CODE, unlike DOES>, is IMMEDIATE,
+* and compiles (;CODE),
+* which will do the actual work of changing
+* the LATEST definition's characteristic when the defining word runs.
+* Assembly is done by the interpreter, rather than the compiler.
+* I could have avoided the anomalous three-byte code fields by
+*
+* Note that the ASSEMBLER is not part of the model (at this time).
+* That means that, until the assembler is ready,
+* if you want to define low-level words,
+* you have to poke (comma) in hand-assembled stuff.
+*
+ FCB $C5 immediate
+ FCC ';COD' ; ';CODE'
+ FCB $C5
+ FDB PSCODE-10
+SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
+ FDB SEMIS
+* note: "QSTACK" will be replaced by "ASSEMBLER" later
+*
+* ######>> screen 43 <<
+* ======>> 119 <<
+* ( --- ) C
+* Make the word currently being defined
+* build a header for DOES> definitions.
+* Actually just compiles a CONSTANT zero
+* which can be overwritten later by DOES>.
+* Since the fig models were established, this technique has been deprecated.
+*
+* Note that <BUILDS is not IMMEDIATE,
+* and therefore executes during a definition's run-time,
+* rather than its compile-time.
+* It is not intended to be used directly,
+* but rather so that one definition word can build another.
+* Also, note that nothing particularly special happens
+* in the defining definition until DOES> executes.
+* The name <BUILDS is intended to be a reminder of what is about to occur.
+*
+* <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
+ FCB $87
+ FCC '<BUILD' ; '<BUILDS'
+ FCB $D3
+ FDB SEMIC-8
+BUILDS FDB DOCOL,ZERO,CON
+ FDB SEMIS
+*
+* ======>> 120 <<
+* ( --- ) ( IP *** ) C
+* Define run-time behavior of definitions compiled/defined
+* by a high-level defining definition --
+* the FORTH equivalent of a compiler-compiler.
+* DOES> assumes that the LATEST symbol table entry
+* has at least one word of parameter field,
+* which <BUILDS provides.
+* Note that DOES> is also not IMMEDIATE.
+*
+* When the defining word containing DOES> executes the DOES> icode,
+* it overwrites the LATEST symbol's CFA with jsr <XDOES,
+* overwrites the first word of that symbol's parameter field with its own IP,
+* and pops the previous IP from the return stack.
+* The icodes which follow DOES> in the stream
+* do not execute at the defining word's run-time.
+*
+* Examining XDOES in the virtual machine shows
+* that the defined word will execute those icodes
+* which follow DOES> at its own run-time.
+*
+* The advantage of this kind of behaviour,
+* which you will also note in ;CODE,
+* is that the defined word can contain
+* both operations and data to be operated on.
+* This is how FORTH data objects define their own behavior.
+*
+* Finally, note that the effective parameter field for DOES> definitions
+* starts two NATWID words after the CFA, instead of just one
+* (four bytes instead of two in a sixteen-bit addressing Forth).
+*
+* VOCABULARYs will use this. See definition of word FORTH.
+ FCB $85
+ FCC 'DOES' ; 'DOES>'
+ FCB $BE
+ FDB BUILDS-10
+* DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
+DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+ FDB LATEST,PFA,STORE
+ FDB PSCODE
+*
+* ( --- PFA+NATWID ) ( *** IP )
+* Characteristic of a DOES> defined word.
+* The characteristics of DOES> definitions are written in high-level
+* Forth codes rather than native CPU machine level code.
+* The first parameter word points to the high-level characteristic.
+* This routine's job is to push the IP,
+* load the high level characteristic pointer in IP,
+* and leave the address following the characteristic pointer on the stack
+* so the parameter field can be accessed.
+DODOES LDD ,S ; Keep the return address.
+ STY ,S ; Save/nest the current IP on the return stack.
+ LDY NATWID,X ; First parameter is new IP.
+ LEAX 2*NATWID,X ; Address of second parameter.
+ PSHU X
+ TFR D,PC ; Synthetic return.
+*
+* From the 6800 model:
+* DODOES LDA IP
+* LDB IP+1
+* LDX RP make room on return stack
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* STA 2,X push return address
+* STB 3,X
+* LDX W get addr of pointer to run-time code
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX N stash it in scratch area
+* LDX 0,X get new IP
+* STX IP
+* CLRA ; get address of parameter
+* LDB #2
+* ADDB N+1
+* ADCA N
+* PSHS B ; and push it on data stack
+* PSHS A ;
+* JMP NEXT2
+*
+* ######>> screen 44 <<
+* ======>> 121 <<
+* ( strptr --- strptr+1 count )
+* Convert counted string to string and count.
+* (Fetch the byte at strptr, post-increment.)
+ FCB $85
+ FCC 'COUN' ; 'COUNT'
+ FCB $D4
+ FDB DOES-8
+COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
+ FDB SEMIS
+*
+* ======>> 122 <<
+* ( strptr count --- )
+* EMIT count characters at strptr.
+ FCB $84
+ FCC 'TYP' ; 'TYPE'
+ FCB $C5
+ FDB COUNT-8
+TYPE FDB DOCOL,DDUP,ZBRAN
+ FDB TYPE3-*-NATWID
+ FDB OVER,PLUS,SWAP,XDO
+TYPE2 FDB I,CAT,EMIT,XLOOP
+ FDB TYPE2-*-NATWID
+ FDB BRAN
+ FDB TYPE4-*-NATWID
+TYPE3 FDB DROP
+TYPE4 FDB SEMIS
+*
+* ======>> 123 <<
+* ( strptr count1 --- strptr count2 )
+* Supress trailing blanks (subtract count of trailing blanks from strptr).
+ FCB $89
+ FCC '-TRAILIN' ; '-TRAILING'
+ FCB $C7
+ FDB TYPE-7
+DTRAIL FDB DOCOL,DUP,ZERO,XDO
+DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
+ FDB SUB,ZBRAN
+ FDB DTRAL3-*-NATWID
+ FDB LEAVE,BRAN
+ FDB DTRAL4-*-NATWID
+DTRAL3 FDB ONE,SUB
+DTRAL4 FDB XLOOP
+ FDB DTRAL2-*-NATWID
+ FDB SEMIS
+*
+* ======>> 124 <<
+* ( --- )
+* TYPE counted string out of instruction stream (updating IP).
+ FCB $84
+ FCC '(."' ; '(.")'
+ FCB $A9
+ FDB DTRAIL-12
+* PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
+* PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
+PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP
+ FDB FROMR,PLUS,TOR,TYPE
+ FDB SEMIS
+*
+* ======>> 125 <<
+* ( --- ) P
+* { ." something-to-be-printed " } typical input
+* Use WORD to parse to trailing quote;
+* if compiling, compile XDOTQ and string parsed,
+* otherwise, TYPE string.
+ FCB $C2 immediate
+ FCC '.' ; '."'
+ FCB $A2
+ FDB PDOTQ-7
+DOTQ FDB DOCOL
+ FDB LIT8
+ FCB $22 ascii quote
+ FDB STATE,AT,ZBRAN
+ FDB DOTQ1-*-NATWID
+ FDB COMPIL,PDOTQ,WORD
+ FDB HERE,CAT,ONEP,ALLOT,BRAN
+ FDB DOTQ2-*-NATWID
+DOTQ1 FDB WORD,HERE,COUNT,TYPE
+DOTQ2 FDB SEMIS
+*
+* ######>> screen 45 <<
+* ======>> 126 <<== MACHINE DEPENDENT
+* ( --- ) ( *** )
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if parameter stack out of bounds.
+*
+* But checking whether the stack is in bounds or not
+* really should not use the stack.
+* And there really should be a ?RSTACK, as well.
+ FCB $86
+ FCC '?STAC' ; '?STACK'
+ FCB $CB
+ FDB DOTQ-5
+QSTACK FDB DOCOL,LIT8
+* FCB $12
+ FCB SINIT-ORIG
+* But why use that instead of XSPZER (S0)?
+* Multi-user or multi-tasking would not want that.
+* CMPU <XSPZER
+* FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
+ FDB PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
+ FDB QERR
+* prints 'empty stack'
+*
+QSTAC2 FDB SPAT
+* Here, we compare with a value at least 128
+* higher than dict. ptr. (DICTPT)
+ FDB HERE,LIT8
+ FCB $80 ; This is a rough check anyway, leave it as is.
+ FDB PLUS,LESS,ZBRAN
+ FDB QSTAC3-*-NATWID
+ FDB TWO ; NOT the NATWID constant!
+ FDB QERR
+* prints 'full stack'
+*
+QSTAC3 FDB SEMIS
+*
+* ======>> 127 << this word's function
+* is done by ?STACK in this version
+* FCB $85
+* FCC 4,?FREE
+* FCB $C5
+* FDB QSTACK-9
+*QFREE FDB DOCOL,SPAT,HERE,LIT8
+* FCB $80
+* FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
+*
+* ######>> screen 46 <<
+* ======>> 128 <<
+* ( buffer n --- )
+* ***** Check that this is how it works here:
+* Get up to n-1 characters from the keyboard,
+* storing at buffer and echoing, with backspace editing,
+* quitting when a CR is read.
+* Terminate it with a NUL.
+ FCB $86
+ FCC 'EXPEC' ; 'EXPECT'
+ FCB $D4
+ FDB QSTACK-9
+EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
+* EXPEC2 FDB KEY,DUP,LIT8
+EXPEC2 FDB KEY
+ FDB LIT,$1C,SHOTOS ; DBG
+ FDB DUP,LIT8
+ FCB BACKSP-ORIG
+ FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing
+ FDB EXPEC3-*-NATWID
+ FDB DROP,LIT8
+ FCB 8 ( backspace character to emit )
+ FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
+ FDB TOR,SUB,BRAN
+ FDB EXPEC6-*-NATWID
+EXPEC3 FDB DUP,LIT8
+ FCB $D ( carriage return )
+ FDB EQUAL,ZBRAN
+ FDB EXPEC4-*-NATWID
+ FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
+ FDB EXPEC5-*-NATWID
+EXPEC4 FDB DUP
+EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
+EXPEC6 FDB EMIT,XLOOP
+ FDB EXPEC2-*-NATWID
+ FDB DROP
+ FDB SEMIS
+*
+* ======>> 129 <<
+* ( --- )
+* EXPECT 128 (TWID) characters to TIB.
+ FCB $85
+ FCC 'QUER' ; 'QUERY'
+ FCB $D9
+ FDB EXPECT-9
+QUERY FDB DOCOL,TIB,AT,COLUMS
+ FDB AT,EXPECT,ZERO,IN,STORE
+ FDB SEMIS
+*
+* ======>> 130 <<
+* ( --- ) P
+* End interpretation of a line or screen, and/or prepare for a new block.
+* Note that the name of this definition is an empty string,
+* so it matches on the terminating NUL in the terminal or block buffer.
+ FCB $C1 immediate < carriage return >
+ FCB $80
+ FDB QUERY-8
+NULL FDB DOCOL,BLK,AT,ZBRAN
+ FDB NULL2-*-NATWID
+ FDB ONE,BLK,PSTORE
+ FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
+ FDB ZEQU
+* check for end of screen
+ FDB ZBRAN
+ FDB NULL1-*-NATWID
+ FDB QEXEC,FROMR,DROP
+NULL1 FDB BRAN
+ FDB NULL3-*-NATWID
+NULL2 FDB FROMR,DROP
+NULL3 FDB SEMIS
+*
+* ######>> screen 47 <<
+* ======>> 133 <<
+* ( adr n b --- )
+* Fill n bytes at adr with b.
+ FCB $84
+ FCC 'FIL' ; 'FILL'
+ FCB $CC
+ FDB NULL-4
+FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
+ FDB FROMR,ONE,SUB,CMOVE
+ FDB SEMIS
+*
+* ======>> 134 <<
+* ( adr n --- )
+* Fill n bytes with 0.
+ FCB $85
+ FCC 'ERAS' ; 'ERASE'
+ FCB $C5
+ FDB FILL-7
+ERASE FDB DOCOL,ZERO,FILL
+ FDB SEMIS
+*
+* ======>> 135 <<
+* ( adr n --- )
+* Fill n bytes with ASCII SPACE.
+ FCB $86
+ FCC 'BLANK' ; 'BLANKS'
+ FCB $D3
+ FDB ERASE-8
+BLANKS FDB DOCOL,BL,FILL
+ FDB SEMIS
+*
+* ======>> 136 <<
+* ( c --- )
+* Format a character at the left of the HLD output buffer.
+ FCB $84
+ FCC 'HOL' ; 'HOLD'
+ FCB $C4
+ FDB BLANKS-9
+HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
+ FDB SEMIS
+*
+* ======>> 137 <<
+* ( --- adr )
+* Give the address of the output PAD buffer.
+* PAD points to the end of a 68 byte buffer for numeric conversion.
+ FCB $83
+ FCC 'PA' ; 'PAD'
+ FCB $C4
+ FDB HOLD-7
+PAD FDB DOCOL,HERE,LIT8
+ FCB $44
+ FDB PLUS
+ FDB SEMIS
+*
+* ######>> screen 48 <<
+* ======>> 138 <<
+* ( c --- )
+* Scan a string terminated by the character c or ASCII NUL out of input;
+* store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
+* Leading c are passed over, per ENCLOSE.
+* Scans from BLK, or from TIB if BLK is zero.
+* May overwrite the numeric conversion pad,
+* if really long (length > 31) symbols are scanned.
+ FCB $84
+ FCC 'WOR' ; 'WORD'
+ FCB $C4
+ FDB PAD-6
+WORD FDB DOCOL,BLK,AT,ZBRAN
+ FDB WORD2-*-NATWID
+ FDB BLK,AT,BLOCK,BRAN
+ FDB WORD3-*-NATWID
+WORD2 FDB TIB,AT
+WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
+ FCB 34
+ FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
+ FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
+ FDB SEMIS
+*
+* ######>> screen 49 <<
+* ======>> 139 <<
+* ( d1 string --- d2 adr )
+* Convert the text at string into a number, accumulating the result into d1,
+* leaving adr pointing to the first character not converted.
+* If DPL is non-negative at entry,
+* accumulates the number of characters converted into DPL.
+ FCB $88
+ FCC '(NUMBER' ; '(NUMBER)'
+ FCB $A9
+ FDB WORD-7
+PNUMB FDB DOCOL
+PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
+ FDB PNUMB4-*-NATWID
+ FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
+ FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
+ FDB PNUMB3-*-NATWID
+ FDB ONE,DPL,PSTORE
+PNUMB3 FDB FROMR,BRAN
+ FDB PNUMB2-*-NATWID
+PNUMB4 FDB FROMR
+ FDB SEMIS
+*
+* ======>> 140 <<
+* ( ctstr --- d )
+* Convert text at ctstr to a double integer,
+* taking the 0 ERROR if the conversion is not valid.
+* If a decimal point is present,
+* accumulate the count of digits to the decimal point's right into DPL
+* (negative DPL at exit indicates single precision).
+* ctstr is a counted string
+* -- the first byte at ctstr is the length of the string,
+* but NUMBER ignores the count and expects a NUL terminator instead.
+ FCB $86
+ FCC 'NUMBE' ; 'NUMBER'
+ FCB $D2
+ FDB PNUMB-11
+NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
+ FCC "-" minus sign
+ FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
+NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
+ FDB ZBRAN
+ FDB NUMB2-*-NATWID
+ FDB DUP,CAT,LIT8
+ FCC "."
+ FDB SUB,ZERO,QERR,ZERO,BRAN
+ FDB NUMB1-*-NATWID
+NUMB2 FDB DROP,FROMR,ZBRAN
+ FDB NUMB3-*-NATWID
+ FDB DMINUS
+NUMB3 FDB SEMIS
+*
+* ======>> 141 <<
+* ( --- locptr length true ) { -FIND name } typical input
+* ( --- false )
+* Parse a word, then FIND,
+* first in the definition vocabulary,
+* then in the CONTEXT (interpretation) vocabulary, if necessary.
+* Returns what (FIND) returns, flag and optional location and length.
+ FCB $85
+ FCC '-FIN' ; '-FIND'
+ FCB $C4
+ FDB NUMB-9
+DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
+ FDB PFIND,DUP,ZEQU,ZBRAN
+ FDB DFIND2-*-NATWID
+ FDB DROP,HERE,LATEST,PFIND
+DFIND2 FDB SEMIS
+*
+* ######>> screen 50 <<
+* ======>> 142 <<
+* ( anything --- nothing ) ( anything *** nothing )
+* An indirection for ABORT, for ERROR,
+* which may be modified carefully.
+ FCB $87
+ FCC '(ABORT' ; '(ABORT)'
+ FCB $A9
+ FDB DFIND-8
+PABORT FDB DOCOL,ABORT
+ FDB SEMIS
+*
+* ======>> 143 <<
+ FCB $85
+ FCC 'ERRO' ; 'ERROR'
+ FCB $D2
+ FDB PABORT-10
+* This really should not be high level, according to best practices.
+* But fixing that cascades through MESSAGE,
+* requiring re-architecting the disk block system.
+* First, we need to get this transliteration running.
+ERROR FDB DOCOL,WARN,AT,ZLESS
+ FDB ZBRAN
+ FDB ERROR2-*-NATWID
+* note: WARNING is
+* -1 to abort,
+* 0 to print error #
+* and 1 to print error message from disc
+ FDB PABORT
+ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
+ FCB 4,7 ( bell )
+ FCC " ? "
+ FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
+ FDB SEMIS
+*
+* ======>> 144 <<
+* ( n adr --- )
+* Mask byte at adr with n.
+* Not in FIG, don't need it for 8 bit characters after all.
+* FCB $85
+* FCC 'CMAS' ; 'CMASK'
+* FCB $CB ; 'K'
+* FDB ERROR-8
+* CMASK FDB *+NATWID
+* LDX ,U++ ; adr
+* LDD ,U++ ; mask
+* ANDB ,X
+* STB ,X
+* RTS
+*
+* ( adr --- adr )
+* Mask high bit of tail of name in PAD buffer.
+* Not in FIG, need it for 8 bit characters.
+ FCB $86
+ FCC 'IDFLA' ; 'IDFLAT'
+ FCB $D4 ; 'T'
+ FDB ERROR-8
+IDFLAT FDB *+NATWID
+ LDX ,U
+ LDB ,X ; get the count
+ ANDB #CTMASK
+ LDA B,X ; point to the tail
+ ANDA #$7F ; Clear the EndOfName flag bit.
+ STA B,X
+ RTS
+*
+* ( symptr --- )
+* Print definition's name from its NFA.
+ FCB $83
+ FCC 'ID' ; 'ID.'
+ FCB $AE
+ FDB IDFLAT-9
+IDDOT FDB DOCOL,PAD,LIT8
+ FCB 32
+ FDB LIT8
+ FCB $5F ( underline )
+ FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
+* FDB SWAP,CMOVE,PAD,COUNT,LIT8
+ FDB SWAP,CMOVE,PAD
+ FDB IDFLAT
+ FDB COUNT,LIT8
+ FCB 31
+ FDB AND,TYPE,SPACE
+ FDB SEMIS
+*
+* ######>> screen 51 <<
+* ======>> 145 <<
+* ( --- ) { CREATE name } input
+* Parse a name (length < 32 characters) and create a header,
+* reporting first duplicate found in either the defining vocabulary
+* or the context (interpreting) vocabulary.
+* Install the header in the defining vocabulary
+* with CFA dangerously pointing to the parameter field.
+* Leave the name SMUDGEd.
+ FCB $86
+ FCC 'CREAT' ; 'CREATE'
+ FCB $C5
+ FDB IDDOT-6
+CREATE FDB DOCOL,DFIND,ZBRAN
+ FDB CREAT2-*-NATWID
+ FDB DROP,PDOTQ
+ FCB 8
+ FCB 7 ( bel )
+ FCC "redef: "
+ FDB NFA,IDDOT,LIT8
+ FCB 4
+ FDB MESS,SPACE
+CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
+ FDB ONEP,ALLOT,DUP,LIT8
+ FCB ($80|FSMUDG) ; Bracket the name.
+ FDB TOGGLE,HERE,ONE,SUB,LIT8
+ FCB $80
+ FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
+* FDB HERE,TWOP,COMMA
+ FDB HERE,NATP,COMMA
+ FDB SEMIS
+*
+* ######>> screen 52 <<
+* ======>> 146 <<
+* ( --- ) P
+* { [COMPILE] name } typical use
+* -DFIND next WORD and COMPILE it, literally;
+* used to compile immediate definitions into words.
+ FCB $C9 immediate
+ FCC '[COMPILE' ; '[COMPILE]'
+ FCB $DD
+ FDB CREATE-9
+BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
+ FDB SEMIS
+*
+* ======>> 147 <<
+* ( n --- ) if compiling. P
+* ( n --- n ) if interpreting.
+* Compile n as a literal, if compiling.
+ FCB $C7 immediate
+ FCC 'LITERA' ; 'LITERAL'
+ FCB $CC
+ FDB BCOMP-12
+LITER FDB DOCOL,STATE,AT,ZBRAN
+ FDB LITER2-*-NATWID
+ FDB COMPIL,LIT,COMMA
+LITER2 FDB SEMIS
+*
+* ======>> 148 <<
+* ( d --- ) if compiling. P
+* ( d --- d ) if interpreting.
+* Compile d as a double literal, if compiling.
+ FCB $C8 immediate
+ FCC 'DLITERA' ; 'DLITERAL'
+ FCB $CC
+ FDB LITER-10
+DLITER FDB DOCOL,STATE,AT,ZBRAN
+ FDB DLITE2-*-NATWID
+ FDB SWAP,LITER,LITER ; Just two literals in the right order.
+DLITE2 FDB SEMIS
+*
+* ######>> screen 53 <<
+* ======>> 149 <<
+* ( --- )
+* Interpret or compile, according to STATE.
+* Searches words parsed in dictionary first, via -FIND,
+* then checks for valid NUMBER.
+* Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
+* ERROR checks the stack via ?STACK before returning to its caller.
+ FCB $89
+ FCC 'INTERPRE' ; 'INTERPRET'
+ FCB $D4
+ FDB DLITER-11
+INTERP FDB DOCOL
+INTER2 FDB DFIND,ZBRAN
+ FDB INTER5-*-NATWID
+ FDB STATE,AT,LESS
+ FDB ZBRAN
+ FDB INTER3-*-NATWID
+ FDB CFA,COMMA,BRAN
+ FDB INTER4-*-NATWID
+INTER3 FDB CFA,EXEC
+INTER4 FDB BRAN
+ FDB INTER7-*-NATWID
+INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
+ FDB INTER6-*-NATWID
+ FDB DLITER,BRAN
+ FDB INTER7-*-NATWID
+INTER6 FDB DROP,LITER
+INTER7 FDB QSTACK,BRAN
+ FDB INTER2-*-NATWID
+* FDB SEMIS never executed
+
+*
+* ######>> screen 54 <<
+* ======>> 150 <<
+* ( --- )
+* Toggle precedence bit of LATEST definition header.
+* During compiling, most symbols scanned are compiled.
+* IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
+* but may be compiled via ' (TICK).
+ FCB $89
+ FCC 'IMMEDIAT' ; 'IMMEDIATE'
+ FCB $C5
+ FDB INTERP-12
+IMMED FDB DOCOL,LATEST,LIT8
+ FCB FIMMED
+ FDB TOGGLE
+ FDB SEMIS
+*
+* ======>> 151 <<
+* ( --- ) { VOCABULARY name } input
+* Create a vocabulary entry with a flag for terminating vocabulary searches.
+* Store the current search context in it for linking.
+* At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
+ FCB $8A
+ FCC 'VOCABULAR' ; 'VOCABULARY'
+ FCB $D9
+ FDB IMMED-12
+VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
+ FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
+* DOVOC FDB TWOP,CONTXT,STORE
+DOVOC FDB NATP,CONTXT,STORE
+ FDB SEMIS
+*
+* ======>> 152 <<
+*
+* Note: FORTH does not go here in the rom-able dictionary,
+* since FORTH is a type of variable.
+*
+* (Should make a proper architecture for this at some point.)
+*
+*
+* ======>> 153 <<
+* ( --- )
+* Makes the current interpretation CONTEXT vocabulary
+* also the CURRENT defining vocabulary.
+ FCB $8B
+ FCC 'DEFINITION' ; 'DEFINITIONS'
+ FCB $D3
+ FDB VOCAB-13
+DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
+ FDB SEMIS
+*
+* ======>> 154 <<
+* ( --- )
+* Parse out a comment and toss it away.
+* Leaves the first 32 characters in WORDPAD, which may or may not be useful.
+ FCB $C1 immediate (
+ FCB $A8
+ FDB DEFIN-14
+PAREN FDB DOCOL,LIT8
+ FCC ")"
+ FDB WORD
+ FDB SEMIS
+*
+* ######>> screen 55 <<
+* ======>> 155 <<
+* ( anything *** nothing )
+* Clear return stack.
+* Then INTERPRET and, if not compiling, prompt with OK,
+* in infinite loop.
+ FCB $84
+ FCC 'QUI' ; 'QUIT'
+ FCB $D4
+ FDB PAREN-4
+QUIT FDB DOCOL,ZERO,BLK,STORE
+ FDB LBRAK
+*
+* Here is the outer interpretter
+* which gets a line of input, does it, prints " OK"
+* then repeats :
+QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
+ FDB ZBRAN
+ FDB QUIT3-*-NATWID
+ FDB PDOTQ
+ FCB 3
+ FCC ' OK' ; ' OK'
+QUIT3 FDB BRAN
+ FDB QUIT2-*-NATWID
+* FDB SEMIS ( never executed )
+*
+* ======>> 156 <<
+* ( anything --- nothing ) ( anything *** nothing )
+* Clear parameter stack,
+* set STATE to interpret and BASE to DECIMAL,
+* return to input from terminal,
+* restore DRIVE OFFSET to 0,
+* print out "Forth-68",
+* set interpret and define vocabularies to FORTH,
+* and finally, QUIT.
+* Used to force the system to a known state
+* and return control to the initial INTERPRETer.
+ FCB $85
+ FCC 'ABOR' ; 'ABORT'
+ FCB $D4
+ FDB QUIT-7
+ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
+ FCB 10
+ FCC "Forth-6809"
+ FDB FORTH,DEFIN
+ FDB QUIT
+* FDB SEMIS never executed
+ PAGE
+*
+* ######>> screen 56 <<
+* bootstrap code... moves rom contents to ram :
+* ======>> 157 <<
+ FCB $84
+ FCC 'COL' ; 'COLD'
+ FCB $C4
+ FDB ABORT-8
+COLD FDB *+NATWID
+* Ultimately, we want position indepence,
+* so I'm using PCR where it seems reasonable.
+CENT LDS SINIT,PCR ; Get a useable return stack, at least.
+ LDA #IUPDP ; This is not relative to PC.
+ TFR A,DP ; And a useable direct page, too.
+ SETDP IUPDP ; (For good measure.)
+*
+* We'll keep this here for the time being.
+* There are better ways to do this, of course.
+* Re-architect, re-architect.
+ LEAX RAM,PCR
+ STX <XFENCE ; Borrow this variable for a loop terminator.
+ LEAY REND,PCR ; top of destination
+ LEAX ERAM,PCR ; top of stuff to move
+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.
+* WENT LDS #XFENCE-1 top of destination
+* LDX #FENCIN top of stuff to move
+* WARM2 LEAX -1,X ;
+* LDA 0,X
+* PSHS A ;
+* CMPX #SINIT
+* BNE WARM2
+*
+* LDS SINIT
+* S is already there.
+* LDX UPINIT
+* STX UP init user ram pointer
+* UP is already there (DP).
+* LDX #ABORT
+* STX IP
+ LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
+*
+ NOP Here is a place to jump to special user
+ NOP initializations such as I/0 interrups
+ NOP
+*
+* For systems with TRACE:
+ LDX #00
+* STX TRLIM clear trace mode
+ STX <TRLIM clear trace mode (both bytes)
+ LDX #0
+* STX BRKPT clear breakpoint address
+ STX <BRKPT clear breakpoint address
+* JMP RPSTOR+2 start the virtual machine running !
+ LBSR RPSTOR+NATWID start the virtual machine running !
+ LBRA NEXT ; But we must also give RP! someplace to return.
+* RP! sets up the return stack pointer, then Y references abort.
+*
+* Here is the stuff that gets copied to ram :
+* (not * at address $140:)
+* at an appropriate address:
+*
+RAM FDB $3000,$3000,0,0
+
+* ======>> (152) <<
+* ( --- ) P
+* Makes FORTH the current interpretation vocabulary.
+* In order to make this ROMmable, this entry is set up as the tail-end,
+* and copied to RAM in the start-up code.
+* We want a more elegant solution to this, too. Greedy, maybe.
+ FCB $C5 immediate
+ FCC 'FORT' ; 'FORTH'
+ FCB $C8
+ FDB NOOP-7 ; Note that this does not link to COLD!
+RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
+ FDB 0
+ FCC "(C) Forth Interest Group, 1979"
+ FCB $84
+ FCC 'TAS' ; 'TASK'
+ FCB $CB
+ FDB FORTH-8
+RTASK FDB DOCOL,SEMIS
+ERAM FCC "David Lion"
+ PAGE
+*
+* ######>> screen 57 <<
+* ======>> 158 <<
+* ( n0 --- d0 )
+* Sign extend n0 to a double integer.
+ FCB $84
+ FCC 'S->' ; 'S->D'
+ FCB $C4
+ FDB COLD-7 ; Note that this does not link to FORTH (RFORTH)!
+STOD FDB DOCOL,DUP,ZLESS,MINUS
+ FDB SEMIS
+
+
+*
+* ======>> 159 <<
+* ( multiplier multiplicand --- product )
+* Signed word multiply.
+ FCB $81 ; *
+ FCB $AA
+ FDB STOD-7
+STAR FDB *+NATWID
+ LBSR USTAR+NATWID ; or [USTAR,PCR]?
+ LEAU NATWID,U ; Drop high word.
+ RTS
+* JSR USTARS
+* LEAS 1,S ;
+* LEAS 1,S ;
+* JMP NEXT
+*
+* ======>> 160 <<
+* ( dividend divisor --- remainder quotient )
+* M/ in word-only form, i. e., signed division of 2nd word by top word,
+* yielding signed word quotient and remainder.
+ FCB $84
+ FCC '/MO' ; '/MOD'
+ FCB $C4
+ FDB STAR-4
+SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
+ FDB SEMIS
+*
+* ======>> 161 <<
+* ( dividend divisor --- quotient )
+* Signed word divide without remainder.
+ FCB $81 ; /
+ FCB $AF
+ FDB SLMOD-7
+SLASH FDB DOCOL,SLMOD,SWAP,DROP
+ FDB SEMIS
+*
+* ======>> 162 <<
+* ( dividend divisor --- remainder )
+* Remainder function, result takes sign of dividend.
+ FCB $83
+ FCC 'MO' ; 'MOD'
+ FCB $C4
+ FDB SLASH-4
+MOD FDB DOCOL,SLMOD,DROP
+ FDB SEMIS
+*
+* ======>> 163 <<
+* ( multiplier multiplicand divisor --- remainder quotient )
+* Signed precise division of product:
+* multiply 2nd and 3rd words on stack
+* and divide the 31-bit product by the top word,
+* leaving both quotient and remainder.
+* Remainder takes sign of product.
+* Guaranteed not to lose significant bits in 16 bit integer math.
+ FCB $85
+ FCC '*/MO' ; '*/MOD'
+ FCB $C4
+ FDB MOD-6
+SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
+ FDB SEMIS
+*
+* ======>> 164 <<
+* ( multiplier multiplicand divisor --- quotient )
+* */MOD without remainder.
+ FCB $82
+ FCC '*' ; '*/'
+ FCB $AF
+ FDB SSMOD-8
+SSLASH FDB DOCOL,SSMOD,SWAP,DROP
+ FDB SEMIS
+*
+* ======>> 165 <<
+* ( ud1 u1 --- u2 ud2 )
+* U/ with an (unsigned) double quotient.
+* Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
+* if you are prepared to deal with the extra 16 bits of result.
+ FCB $85
+ FCC 'M/MO' ; 'M/MOD'
+ FCB $C4
+ FDB SSLASH-5
+MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
+ FDB FROMR,SWAP,TOR,USLASH,FROMR
+ FDB SEMIS
+*
+* ======>> 166 <<
+* ( n>=0 --- n )
+* ( n<0 --- -n )
+* Convert the top of stack to its absolute value.
+ FCB $83
+ FCC 'AB' ; 'ABS'
+ FCB $D3
+ FDB MSMOD-8
+ABS FDB DOCOL,DUP,ZLESS,ZBRAN
+ FDB ABS2-*-NATWID
+ FDB MINUS
+ABS2 FDB SEMIS
+*
+* ======>> 167 <<
+* ( d>=0 --- d )
+* ( d<0 --- -d )
+* Convert the top double to its absolute value.
+ FCB $84
+ FCC 'DAB' ; 'DABS'
+ FCB $D3
+ FDB ABS-6
+DABS FDB DOCOL,DUP,ZLESS,ZBRAN
+ FDB DABS2-*-NATWID
+ FDB DMINUS
+DABS2 FDB SEMIS
+*
+* ######>> screen 58 <<
+* Disc primitives :
+* ======>> 168 <<
+* ( --- vadr )
+* Least Recently Used buffer.
+* Really should be with FIRST and LIMIT in the per-task table.
+ FCB $83
+ FCC 'US' ; 'USE'
+ FCB $C5
+ FDB DABS-7
+USE FDB DOCON
+ FDB XUSE
+* ======>> 169 <<
+* ( --- vadr )
+* Most Recently Used buffer.
+* Really should be with FIRST and LIMIT in the per-task table.
+ FCB $84
+ FCC 'PRE' ; 'PREV'
+ FCB $D6
+ FDB USE-6
+PREV FDB DOCON
+ FDB XPREV
+* ======>> 170 <<
+* ( buffer1 --- buffer2 f )
+* Bump to next buffer,
+* flag false if result is PREVious buffer,
+* otherwise flag true.
+* Used in the LRU allocation routines.
+ FCB $84
+ FCC '+BU' ; '+BUF'
+ FCB $C6
+ FDB PREV-7
+PBUF FDB DOCOL,LIT8
+ FCB $84
+ FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
+ FDB PBUF2-*-NATWID
+ FDB DROP,FIRST
+PBUF2 FDB DUP,PREV,AT,SUB
+ FDB SEMIS
+*
+* ======>> 171 <<
+* ( --- )
+* 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 SEMIS
+*
+* ======>> 172 <<
+* ( --- )
+* Mark all buffers empty.
+* Standard method of discarding changes.
+ FCB $8D
+ FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
+ FCB $D3
+ FDB UPDATE-9
+MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
+ FDB SEMIS
+*
+* ======>> 173 <<
+* ( --- )
+* Clear the current offset to the block numbers in the drive interface.
+* The drives need to be re-architected.
+* Would be cool to have RAM and ROM drives supported
+* in addition to regular physical persistent store.
+ FCB $83
+ FCC 'DR' ; 'DR0'
+ FCB $B0
+ FDB MTBUF-16
+DRZERO FDB DOCOL,ZERO,OFSET,STORE
+ FDB SEMIS
+*
+* ======>> 174 <<== system dependant word
+* ( --- )
+* Set the current offset in the drive interface to reference the second drive.
+* The hard-coded number in there needs to be in a table.
+ FCB $83
+ FCC 'DR' ; 'DR1'
+ FCB $B1
+ FDB DRZERO-6
+DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
+ FDB SEMIS
+*
+* ######>> screen 59 <<
+* ======>> 175 <<
+* ( n --- buffer )
+* Get a free buffer,
+* assign it to block n,
+* return buffer address.
+* Will free a buffer by writing it, if necessary.
+* Does not actually read the block.
+* A bug in the fig LRU algorithm, which I have not fixed,
+* gives the PREVious buffer if USE gets set to PREVious.
+* (The bug is that USE sometimes gets set to PREVious.)
+* This bug sometimes causes sector moves to become sector fills.
+ FCB $86
+ FCC 'BUFFE' ; 'BUFFER'
+ FCB $D2
+ FDB DRONE-6
+BUFFER FDB DOCOL,USE,AT,DUP,TOR
+BUFFR2 FDB PBUF,ZBRAN
+ FDB BUFFR2-*-NATWID
+ FDB USE,STORE,R,AT,ZLESS
+ FDB ZBRAN
+ FDB BUFFR3-*-NATWID
+* FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
+ FDB R,NATP,R,AT,LIT,$7FFF,AND,ZERO,RW
+* BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
+BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
+ FDB SEMIS
+*
+* ######>> screen 60 <<
+* ======>> 176 <<
+* ( n --- buffer )
+* Get BUFFER containing block n, relative to OFFSET.
+* If block n is not in a buffer, bring it in.
+* Returns buffer address.
+ FCB $85
+ FCC 'BLOC' ; 'BLOCK'
+ FCB $CB
+ FDB BUFFER-9
+BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
+ FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
+ FDB BLOCK5-*-NATWID
+BLOCK3 FDB PBUF,ZEQU,ZBRAN
+ FDB BLOCK4-*-NATWID
+* FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
+ FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
+BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
+ FDB BLOCK3-*-NATWID
+ FDB DUP,PREV,STORE
+* BLOCK5 FDB FROMR,DROP,TWOP
+BLOCK5 FDB FROMR,DROP,NATP
+ FDB SEMIS
+*
+* ######>> screen 61 <<
+* ======>> 177 <<
+* ( line screen --- buffer C/L)
+* Bring in the sector containing the specified line of the specified screen.
+* Returns the buffer address and the width of the screen.
+* Screen number is relative to OFFSET.
+* The line number may be beyond screen 4,
+* (LINE) will get the appropriate screen.
+ FCB $86
+ FCC '(LINE' ; '(LINE)'
+ FCB $A9
+ FDB BLOCK-8
+PLINE FDB DOCOL,TOR,LIT8
+ FCB $40
+ FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
+ FCB $40
+ FDB SEMIS
+*
+* ======>> 178 <<
+* ( line screen --- )
+* Print the line of the screen as found by (LINE), suppress trailing BLANKS.
+ FCB $85
+ FCC '.LIN' ; '.LINE'
+ FCB $C5
+ FDB PLINE-9
+DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
+ FDB SEMIS
+*
+* ======>> 179 <<
+* ( n --- )
+* If WARNING is 0, print "MESSAGE #n";
+* otherwise, print line n relative to screen 4,
+* the line number may be negative.
+* Uses .LINE, but counter-adjusts to be relative to the real drive 0.
+ FCB $87
+ FCC 'MESSAG' ; 'MESSAGE'
+ FCB $C5
+ FDB DLINE-8
+MESS FDB DOCOL,WARN,AT,ZBRAN
+ FDB MESS3-*-NATWID
+ FDB DDUP,ZBRAN
+ FDB MESS3-*-NATWID
+ FDB LIT8
+ FCB 4
+ FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
+ FDB MESS4-*-NATWID
+MESS3 FDB PDOTQ
+ FCB 6
+ FCC 'err # ' ; 'err # '
+ FDB DOT
+MESS4 FDB SEMIS
+*
+* ======>> 180 <<
+* ( n --- )
+* Begin interpretation of screen (block) n.
+* See also ARROW, SEMIS, and NULL.
+ FCB $84
+ FCC 'LOA' ; 'LOAD' : input:scr #
+ FCB $C4
+ FDB MESS-10
+LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
+ FDB BSCR,STAR,BLK,STORE
+ FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
+ FDB SEMIS
+*
+* ======>> 181 <<
+* ( --- ) P
+* Continue interpreting source code on the next screen.
+ FCB $C3
+ FCC '--' ; '-->'
+ FCB $BE
+ FDB LOAD-7
+ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
+ FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
+ FDB SEMIS
+ PAGE
+*
+*
+* ######>> screen 63 <<
+* The next 4 subroutines are machine dependent, and are
+* called by words 13 through 16 in the dictionary.
+*
+* ======>> 182 << code for EMIT
+* ( --- ) No parameter stack effect.
+* Interfaces directly with ROM. Expects output character in D (therefore, B).
+* Output using rom CHROUT: redirectable to a printer on Coco.
+* Outputs the character on stack (low byte of 1 bit word/cell).
+PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.)
+ TFR B,A ; Coco ROM wants it in A.
+ CLRB
+ TFR B,DP ; Give the ROM its direct page.
+ JSR [$A002] ; Output the character in A.
+ PULS Y,U,DP,PC
+* PEMIT STB N save B
+* STX N+1 save X
+* LDB ACIAC
+* BITB #2 check ready bit
+* BEQ PEMIT+4 if not ready for more data
+* STA ACIAD
+* LDX UP
+* STB IOSTAT-UORIG,X
+* LDB N recover B & X
+* LDX N+1
+* RTS only A register may change
+* PEMIT JMP $E1D1 for MIKBUG
+* PEMIT FCB $3F,$11,$39 for PROTO
+* PEMIT JMP $D286 for Smoke Signal DOS
+*
+* ======>> 183 << code for KEY
+* ( --- ) No parameter stack effect.
+* Returns character or break flag in D, since this interfaces with Coco ROM.
+* Wait for key from POLCAT on Coco.
+* Returns the character code for the key pressed.
+PKEY PSHS Y,U,DP ; Must save everything important for this one.
+ LDA #$CF ; a cursor of sorts
+ CLRB
+ TFR B,DP
+ SETDP 0
+ LDX <$88 ; location
+ LDB ,X ; save glyph
+ STA ,X
+PKEYLP JSR [$A000]
+ STA $41A ; DBG!
+ BEQ PKEYLP
+ STD $418 ; DBG!
+ STB ,X ; restore
+PKEYR CLRB ; for the break flag, shares code with PQTER
+ CMPA #3 ; break key
+ BNE PKEYGT
+ COMB ; for the break flag
+PKEYGT EXG A,B ; Leave it in D for return.
+ PULS Y,U,DP,PC ; Shares exit with PQTER
+ SETDP IUPDP
+* PKEY STB N
+* STX N+1
+* LDB ACIAC
+* ASRB ;
+* BCC PKEY+4 no incoming data yet
+* LDA ACIAD
+* ANDA #$7F strip parity bit
+* LDX UP
+* STB IOSTAT+1-UORIG,X
+* LDB N
+* LDX N+1
+* RTS
+* PKEY JMP $E1AC for MIKBUG
+* PKEY FCB $3F,$14,$39 for PROTO
+* PKEY JMP $D289 for Smoke Signal DOS
+*
+* ######>> screen 64 <<
+* ======>> 184 << code for ?TERMINAL
+* ( --- f ) Should change this to no stack effect.
+* check break key using POLCAT
+* Returns a flag to tell whether the break key was pressed or not.
+PQTER PSHS Y,U,DP
+ CLRB
+ TFR B,DP
+ JSR [$A000] ; Look but don't wait.
+ BRA PKEYR
+* PQTER LDA ACIAC Test for 'break' condition
+* ANDA #$11 mask framing error bit and
+* input buffer full
+* BEQ PQTER2
+* LDA ACIAD clear input buffer
+* LDA #01
+* PQTER2 RTS
+
+
+ PAGE
+*
+* ======>> 185 << code for CR
+* ( --- ) No stack effect.
+* Interfaces directly with ROM.
+* For Coco just output a CR.
+* Also subject to redirection in Coco BASIC ROM.
+PCR LDB #$0D
+ BRA PEMIT ; Just steal the code.
+* PCR LDA #$D carriage return
+* BSR PEMIT
+* LDA #$A line feed
+* BSR PEMIT
+* LDA #$7F rubout
+* LDX UP
+* LDB XDELAY+1-UORIG,X
+* PCR2 DECB ;
+* BMI PQTER2 return if minus
+* PSHS B ; save counter
+* BSR PEMIT print RUBOUTs to delay.....
+* PULS B ;
+* BRA PCR2 repeat
+
+
+ PAGE
+*
+* ######>> screen 66 <<
+* ======>> 187 <<
+* ( ??? )
+* Query the disk, I suppose.
+* Not sure what the model had in mind for this stub.
+ FCB $85
+ FCC '?DIS' ; '?DISC'
+ FCB $C3
+ FDB ARROW-6
+QDISC FDB *+NATWID
+ JMP NEXT
+*
+* ######>> screen 67 <<
+* ======>> 189 <<
+* ( ??? )
+* Write one block of data to disk.
+* Parameters unspecified in model. Stub in model.
+ FCB $8B
+ FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
+ FCB $C5
+ FDB QDISC-8
+BWRITE FDB *+NATWID
+ JMP NEXT
+*
+* ######>> screen 68 <<
+* ======>> 190 <<
+* ( ??? )
+* Read one block of data from disk.
+* Parameters unspecified in model. Stub in model.
+ FCB $8A
+ FCC 'BLOCK-REA' ; 'BLOCK-READ'
+ FCB $C4
+ FDB BWRITE-14
+BREAD FDB *+NATWID
+ JMP NEXT
+*
+*The next 3 words are written to create a substitute for disc
+* mass memory,located between $3210 & $3FFF in ram.
+* ======>> 190.1 <<
+ FCB $82
+ FCC 'L' ; 'LO'
+ FCB $CF
+ FDB BREAD-13
+LO FDB DOCON
+ FDB MEMEND a system dependent equate at front
+*
+* ======>> 190.2 <<
+ FCB $82
+ FCC 'H' ; 'HI'
+ FCB $C9
+ FDB LO-5
+HI FDB DOCON
+ FDB MEMTOP ( $3FFF or $7FFF in this version )
+*
+* ######>> screen 69 <<
+* ======>> 191 <<
+* ( buffer sector f --- )
+* Read or Write the specified (absolute -- ignores OFFSET) sector
+* from or to the specified buffer.
+* A zero flag specifies write,
+* non-zero specifies read.
+* Sector is an unsigned integer,
+* buffer is the buffer's address.
+* Will need to use the CoCo ROM disk routines.
+* For now, provides a virtual disk in RAM.
+ FCB $83
+ FCC 'R/' ; 'R/W'
+ FCB $D7
+ FDB HI-5
+RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
+ FDB RW2-*-NATWID
+ FDB PDOTQ
+ FCB 8
+ FCC ' Range ?' ; ' Range ?'
+ FDB QUIT
+RW2 FDB FROMR,ZBRAN
+ FDB RW3-*-NATWID
+ FDB SWAP
+RW3 FDB BBUF,CMOVE
+ FDB SEMIS
+*
+* From BIF-6809:
+* RW PSHS Y,U,DP
+* LDY $C006 control table
+* LDX #DROFFS+7 ; This is BIF's table of drive sizes.
+* LDD 2,U
+* RWD SUBD ,X++ sectors
+* BHS RWD
+* BVC RWR table end?
+* LDD #6
+* PSHU D
+* JMP ERROR
+* RWR ADDD ,--X back one
+* PSHS X
+* PSHU D
+* LDD #18 sectors/track
+* PSHU D
+* DOCOL
+* FDB SLAMOD
+* FDB XMACH
+* PULU D
+* STB 2,Y track
+* PULU D
+* INCB
+* STB 3,Y sector
+* PULS D table entry
+* SUBD #DROFFS+7
+* ASRB drive #
+* STB 1,Y
+* LDD 4,U buffer
+* STD 4,Y
+* LDB #2 coco READ
+* LDX ,U 0?
+* BNE *+3
+* INCB coco WRITE
+* STB ,Y op code
+* CLRA
+* TFR A,DP
+* JSR [$C004] ROM handles timeout
+* PULS Y,U,DP if IRQ enabled
+* LEAU 6,U
+* LDX $C006
+* LDB 6,X coco status
+* BEQ RWE
+* LDX <UP
+* LDD #0 no disc
+* STD UWARN,X
+* LDD #8
+* PSHU D
+* JMP ERROR
+* RWE NEXT
+*
+* ######>> screen 72 <<
+* ======>> 192 <<
+* ( --- ) compiling P
+* ( --- adr ) interpreting
+* { ' name } input
+* Parse a symbol name from input and search the dictionary for it, per -FIND;
+* compile the address as a literal if compiling,
+* otherwise just push it.
+ FCB $C1 immediate
+ FCB $A7 ' ( tick )
+ FDB RW-6
+TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
+ FDB SEMIS
+*
+* ======>> 193 <<
+* ( --- ) { FORGET name } input
+* Parse out name of definition to FORGET to, -DFIND it,
+* then lop it and everything that follows out of the dictionary.
+* In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
+ FCB $86
+ FCC 'FORGE' ; 'FORGET'
+ FCB $D4
+ FDB TICK-4
+FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
+ FCB $18
+ FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT8
+ FCB $15
+ FDB QERR,DUP,ZERO,PORIG,GREAT,LIT8
+ FCB $15
+ FDB QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
+ FDB SEMIS
+*
+* ######>> screen 73 <<
+* ======>> 194 <<
+* ( adr --- ) C
+* Calculate a back reference from HERE and compile it.
+ FCB $84
+ FCC 'BAC' ; 'BACK'
+ FCB $CB
+ FDB FORGET-9
+BACK FDB DOCOL,HERE,SUB,COMMA
+ FDB SEMIS
+*
+* ======>> 195 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop test UNTIL
+* typical use: BEGIN code-loop AGAIN
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* ( --- adr n ) compile time P,C
+* Push HERE for BACK reference for general (non-counting) loops,
+* with BEGIN construct flag.
+* A better flag: $4245 (ASCII for 'BE').
+ FCB $C5
+ FCC 'BEGI' ; 'BEGIN'
+ FCB $CE
+ FDB BACK-7
+BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
+ FDB SEMIS
+*
+* ======>> 196 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ENDIF is just a sort of intersection piece,
+* marking where execution resumes after both branches.
+* ( adr n --- ) compile time
+* Check the mark and resolve the IF.
+* A better flag: $4846 (ASCII for 'IF').
+ FCB $C5
+ FCC 'ENDI' ; 'ENDIF'
+ FCB $C6
+ FDB BEGIN-8
+ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
+ FDB OVER,SUB,SWAP,STORE
+ FDB SEMIS
+*
+* ======>> 197 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ( adr n --- )
+* Alias for ENDIF .
+ FCB $C4
+ FCC 'THE' ; 'THEN'
+ FCB $CE
+ FDB ENDIF-8
+THEN FDB DOCOL,ENDIF
+ FDB SEMIS
+*
+* ======>> 198 <<
+* ( limit index --- ) runtime
+* typical use: DO code-loop LOOP
+* typical use: DO code-loop increment +LOOP
+* Counted loop, index is initial value of index.
+* Will loop until index equals (positive going)
+* or passes (negative going) limit.
+* ( --- adr n ) compile time P,C
+* Compile (DO), push HERE for BACK reference,
+* and push DO control construct flag.
+* A better flag: $444F (ASCII for 'DO').
+ FCB $C2
+ FCC 'D' ; 'DO'
+ FCB $CF
+ FDB THEN-7
+DO FDB DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
+ FDB SEMIS
+*
+* ======>> 199 <<
+* ( --- ) runtime
+* typical use: DO code-loop LOOP
+* Increments the index by one and branches back to beginning of loop.
+* Will loop until index equals limit.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (LOOP), fill in BACK reference.
+* A better flag: $444F (ASCII for 'DO').
+ FCB $C4
+ FCC 'LOO' ; 'LOOP'
+ FCB $D0
+ FDB DO-5
+LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
+ FDB SEMIS
+*
+* ======>> 200 <<
+* ( n --- ) runtime
+* typical use: DO code-loop increment +LOOP
+* Increments the index by n and branches back to beginning of loop.
+* Will loop until index equals (positive going)
+* or passes (negative going) limit.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (+LOOP), fill in BACK reference.
+* A better flag: $444F (ASCII for 'DO').
+ FCB $C5
+ FCC '+LOO' ; '+LOOP'
+ FCB $D0
+ FDB LOOP-7
+PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
+ FDB SEMIS
+*
+* ======>> 201 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test UNTIL
+* Will loop until UNTIL tests true.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (0BRANCH), fill in BACK reference.
+* A better flag: $4245 (ASCII for 'BE').
+ FCB $C5
+ FCC 'UNTI' ; 'UNTIL' : ( same as END )
+ FCB $CC
+ FDB PLOOP-8
+UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
+ FDB SEMIS
+*
+* ######>> screen 74 <<
+* ======>> 202 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test END
+* ( adr n --- )
+* Alias for UNTIL .
+ FCB $C3
+ FCC 'EN' ; 'END'
+ FCB $C4
+ FDB UNTIL-8
+END FDB DOCOL,UNTIL
+ FDB SEMIS
+*
+* ======>> 203 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop AGAIN
+* Will loop forever
+* (or until something uses R> DROP to force the current definition to die,
+* or perhaps ABORT or ERROR or some such other drastic means stops things).
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (0BRANCH), fill in BACK reference.
+* A better flag: $4245 (ASCII for 'BE').
+ FCB $C5
+ FCC 'AGAI' ; 'AGAIN'
+ FCB $CE
+ FDB END-6
+AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
+ FDB SEMIS
+*
+* ======>> 204 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* Will loop until WHILE tests false, skipping code-true on end.
+* REPEAT marks where execution resumes after the WHILE find a false flag.
+* ( aadr1 n1 adr2 n2 --- ) compile time P,C
+* Check the marks for WHILE and BEGIN,
+* compile BRANCH and BACK fill adr1 reference,
+* FILL-IN 0BRANCH reference at adr2.
+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+ FCB $C6
+ FCC 'REPEA' ; 'REPEAT'
+ FCB $D4
+ FDB AGAIN-8
+REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
+ FDB TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
+ FDB SEMIS
+*
+* ======>> 205 <<
+* ( n --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* Will pass execution to the true part on a true flag
+* and to the false part on a false flag.
+* ( --- adr n ) compile time P,C
+* Compile a 0BRANCH and dummy offset
+* and push IF reference to fill in and
+* IF control construct flag.
+* A better flag: $4946 (ASCII for 'IF').
+ FCB $C2
+ FCC 'I' ; 'IF'
+ FCB $C6
+ FDB REPEAT-9
+IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
+ FDB SEMIS
+*
+* ======>> 206 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ELSE is just a sort of intersection piece,
+* marking where execution resumes on a false branch.
+* ( adr1 n --- adr2 n ) compile time P,C
+* Check the marks,
+* compile BRANCH with dummy offset,
+* resolve IF reference,
+* and leave reference to BRANCH for ELSE.
+* A better flag: $4946 (ASCII for 'IF').
+ FCB $C4
+ FCC 'ELS' ; 'ELSE'
+ FCB $C5
+ FDB IF-5
+ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
+ FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
+ FDB SEMIS
+*
+* ======>> 207 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* Will loop until WHILE tests false, skipping code-true on end.
+* ( --- adr n ) compile time P,C
+* Compile 0BRANCH with dummy offset (using IF),
+* push WHILE reference.
+* BEGIN flag will sit underneath this.
+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+ FCB $C5
+ FCC 'WHIL' ; 'WHILE'
+ FCB $C5
+ FDB ELSE-7
+WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
+ FDB SEMIS
+*
+* ######>> screen 75 <<
+* ======>> 208 <<
+* ( count --- )
+* EMIT count spaces, for non-zero, non-negative counts.
+ FCB $86
+ FCC 'SPACE' ; 'SPACES'
+ FCB $D3
+ FDB WHILE-8
+SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
+ FDB SPACE3-*-NATWID
+ FDB ZERO,XDO
+SPACE2 FDB SPACE,XLOOP
+ FDB SPACE2-*-NATWID
+SPACE3 FDB SEMIS
+*
+* ======>> 209 <<
+* ( --- )
+* Initialize HLD for converting a double integer.
+* Stores the PAD address in HLD.
+ FCB $82
+ FCC '<' ; '<#'
+ FCB $A3
+ FDB SPACES-9
+BDIGS FDB DOCOL,PAD,HLD,STORE
+ FDB SEMIS
+*
+* ======>> 210 <<
+* ( d --- string length )
+* Terminate numeric conversion,
+* drop the number being converted,
+* leave the address of the conversion string and the length, ready for TYPE.
+ FCB $82
+ FCC '#' ; '#>'
+ FCB $BE
+ FDB BDIGS-5
+EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
+ FDB SEMIS
+*
+* ======>> 211 <<
+* ( n d --- d )
+* Put sign of n (as a flag) at the head of the conversion string.
+* Drop the sign flag.
+ FCB $84
+ FCC 'SIG' ; 'SIGN'
+ FCB $CE
+ FDB EDIGS-5
+SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
+ FDB SIGN2-*-NATWID
+ FDB LIT8
+ FCC "-"
+ FDB HOLD
+SIGN2 FDB SEMIS
+*
+* ======>> 212 <<
+* ( d --- d/base )
+* Generate next most significant digit in the conversion BASE,
+* putting the digit at the head of the conversion string.
+ FCB $81 #
+ FCB $A3
+ FDB SIGN-7
+DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
+ FCB 9
+ FDB OVER,LESS,ZBRAN
+ FDB DIG2-*-NATWID
+ FDB LIT8
+ FCB 7
+ FDB PLUS
+DIG2 FDB LIT8
+ FCC "0" ascii zero
+ FDB PLUS,HOLD
+ FDB SEMIS
+*
+* ======>> 213 <<
+* ( d --- dzero )
+* Convert d to a numeric string using # until the result is zero.
+* Leave the double result on the stack for #> to drop.
+ FCB $82
+ FCC '#' ; '#S'
+ FCB $D3
+ FDB DIG-4
+DIGS FDB DOCOL
+DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
+ FDB DIGS2-*-NATWID
+ FDB SEMIS
+*
+* ######>> screen 76 <<
+* ======>> 214 <<
+* ( n width --- )
+* Print n on the output device in the current conversion base,
+* with sign,
+* right aligned in a field at least width wide.
+ FCB $82
+ FCC '.' ; '.R'
+ FCB $D2
+ FDB DIGS-5
+DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
+ FDB SEMIS
+*
+* ======>> 215 <<
+* ( d width --- )
+* Print d on the output device in the current conversion base,
+* with sign,
+* right aligned in a field at least width wide.
+ FCB $83
+ FCC 'D.' ; 'D.R'
+ FCB $D2
+ FDB DOTR-5
+DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
+ FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
+ FDB SEMIS
+*
+* ======>> 216 <<
+* D. ( d --- )
+* Print d on the output device in the current conversion base,
+* with sign,
+* in free format with trailing space.
+ FCB $82
+ FCC 'D' ; 'D.'
+ FCB $AE
+ FDB DDOTR-6
+DDOT FDB DOCOL,ZERO,DDOTR,SPACE
+ FDB SEMIS
+*
+* ======>> 217 <<
+* ( n --- )
+* Print n on the output device in the current conversion base,
+* with sign,
+* in free format with trailing space.
+ FCB $81 .
+ FCB $AE
+ FDB DDOT-5
+DOT FDB DOCOL,STOD,DDOT
+ FDB SEMIS
+*
+* ======>> 218 <<
+* ( adr --- )
+* Print signed word at adr, per DOT.
+ FCB $81 ?
+ FCB $BF
+ FDB DOT-4
+QUEST FDB DOCOL,AT,DOT
+ FDB SEMIS
+*
+* ######>> screen 77 <<
+* ======>> 219 <<
+* ( n --- )
+* Print out screen n as a field of ASCII,
+* with line numbers in decimal.
+ FCB $84
+ FCC 'LIS' ; 'LIST'
+ FCB $D4
+ FDB QUEST-4
+LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
+ FCB 6
+ FCC "SCR # "
+ FDB DOT,LIT8
+ FCB $10
+ FDB ZERO,XDO
+LIST2 FDB CR,I,THREE
+ FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
+ FDB LIST2-*-NATWID
+ FDB CR
+ FDB SEMIS
+*
+* ======>> 220 <<
+* ( start end --- )
+* Print comment lines (line 0, and line 1 if C/L < 41) of screens
+* from start to end.
+ FCB $85
+ FCC 'INDE' ; 'INDEX'
+ FCB $D8
+ FDB LIST-7
+INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
+INDEX2 FDB CR,I,THREE
+ FDB DOTR,SPACE,ZERO,I,DLINE
+ FDB QTERM,ZBRAN
+ FDB INDEX3-*-NATWID
+ FDB LEAVE
+INDEX3 FDB XLOOP
+ FDB INDEX2-*-NATWID
+ FDB SEMIS
+*
+* ======>> 221 <<
+* ( n --- )
+* List a printer page full of screens.
+* Line and screen number are in current base.
+ FCB $85
+ FCC 'TRIA' ; 'TRIAD'
+ FCB $C4
+ FDB INDEX-8
+TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
+ FDB THREE,OVER,PLUS,SWAP,XDO
+TRIAD2 FDB CR,I
+ FDB LIST,QTERM,ZBRAN
+ FDB TRIAD3-*-NATWID
+ FDB LEAVE
+TRIAD3 FDB XLOOP
+ FDB TRIAD2-*-NATWID
+ FDB CR,LIT8
+ FCB $0F
+ FDB MESS,CR
+ FDB SEMIS
+*
+* ######>> screen 78 <<
+* ======>> 222 <<
+* ( --- )
+* Alphabetically list the definitions in the current vocabulary.
+ FCB $85
+ FCC 'VLIS' ; 'VLIST'
+ FCB $D4
+ FDB TRIAD-8
+VLIST FDB DOCOL,LIT8
+ FCB $80
+ FDB OUT,STORE,CONTXT,AT,AT
+VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
+ FCB 32
+ FDB SUB,GREAT,ZBRAN
+ FDB VLIST2-*-NATWID
+ FDB CR,ZERO,OUT,STORE
+VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
+ FDB DUP,ZEQU,QTERM,OR,ZBRAN
+ FDB VLIST1-*-NATWID
+ FDB DROP
+ FDB SEMIS
+*
+* ======>> XX <<
+* ( --- )
+* Mostly for place holding.
+ FCB $84
+ FCC 'NOO' ; 'NOOP'
+ FCB $D0
+ FDB VLIST-8
+NOOP FDB NEXT a useful no-op
+ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
+
+ PAGE
+* These things, up through the lable 'REND', are overwritten
+* at time of cold load and should have the same contents
+* as shown here:
+*
+* This can be moved whereever the bottom of the
+* user's dictionary is going to be put.
+*
+ 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
+ OPT L
+ END
OSDN Git Service
