OSDN > 軟體搜索 > fig-forth-6809 > SCM > git > fig-forth-6809 > 提交

fig-forth-6809
Fork

R/O
HTTP
SSH
HTTPS

fig-forth-6809: 提交

Source code for a fig Forth interpreter/compiler for the M6809.
M6809用の Forth 原語インタープリター・コンパイラーのソースコード。

Commit MetaInfo

修訂	e46b46eb9b62c4d9a073cdcd09ebd7e460e31b6a (tree)
時間	2022-01-29 16:40:08
作者	Joel Matthew Rees <joel.rees@gmai...>
Commiter	Joel Matthew Rees

Log Message

Merge branch 'auto-hand-optimized' (skipping detour)

Change Summary

add: README.TEXT (diff)
add: commands.text (diff)
add: fig-forth-6809_jmp.asm (diff)
add: fig-forth-6809_ret.asm (diff)
delete: fig-forth-auto6809.asm
delete: figd6809.dsk => junkpile/figd6809.dsk
add: junkpile/a.out (diff)
add: junkpile/fig-forth-auto6809opt.list (diff)
add: junkpile/fig-forth-auto6809opt.list~ (diff)
add: junkpile/fig-forth-auto6809opt12.asm (diff)
add: junkpile/figao.dsk (diff)
add: junkpile/figauto6809opt.dsk (diff)
add: junkpile/work.dsk (diff)
add: junkpile/workfig.dsk (diff)

差異

--- /dev/null

+++ b/README.TEXT

		@@ -0,0 +1,38 @@
	1	+I think the current branch is auto-hand-optimized.
	2	+
	3	+I currently think the path I took to get here was sort of as follows:
	4	+
	5	+1: hand-translated
	6	+(fig-forth_6809.asm -- an attempt to simply re-write with help)
	7	+
	8	+2: search-and-replace
	9	+(fig6800to6809dumb.asm -- a least-work attempt, probably automatic)
	10	+(socialize6809.pl -- a script to convert to more modern syntax)
	11	+
	12	+3: auto
	13	+(6800to6809.pl -- incomplete automatic translation script)
	14	+(figd6809.dsk -- color computer disk image used in testing and debugging)
	15	+
	16	+4: auto-hand-optimized-offline -- see NEXT loop for clues
	17	+(fig-forth-auto6809.asm -- script output)
	18	+(fig-forth-auto6809halfopt.asm -- replacing sequences with single instructions)
	19	+(fig-forth-auto6809opt.asm -- native registers in use, parameter stack is U)
	20	+
	21	+5: auto-hand-optimized-detour (lopped branch)
	22	+(figao.asm -- Trying to mix explicit inner loop with subroutine inner loop.)
	23	+
	24	+6: auto-hand-optimized (current, JMP and JSR proceeding in parallel, in suspended animation)
	25	+fig-forth-auto6809.asm -> fig-forth-6809_jmp.asm -- Explicit NEXT loop, requires JMP/LBRA to NEXT
	26	+fig-forth-auto6809opt.asm -> fig-forth-6809_ret -- subroutine NEXT, RET comes back to NEXT
	27	+
	28	+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.
	29	+
	30	+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.
	31	+
	32	+The source files of most interest are fig-forth-6809_jmp.asm and fig-forth-6809_ret.asm.
	33	+
	34	+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).
	35	+
	36	+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.
	37	+
	38	+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

+++ b/commands.text

		@@ -0,0 +1,44 @@
	1	+imgtool dir coco_jvc_rsdos figauto6809opt.dsk
	2	+imgtool dir coco_jvc_rsdos workfig.dsk
	3	+
	4	+imgtool del coco_jvc_rsdos workfig.dsk FIG.BIN
	5	+
	6	+[imgtool put coco_jvc_rsdos figauto6809opt.dsk figao09.bin FIGAO09.BIN]
	7	+imgtool put coco_jvc_rsdos workfig.dsk a.out FIG.BIN
	8	+
	9	+
	10	+../../lwtools-4.14/lwasm/lwasm --list=fig-forth-auto6809opt.list fig-forth-auto6809opt.asm
	11	+../../lwtools-4.14/lwasm/lwasm --list=fig-forth-auto6809.list fig-forth-auto6809.asm
	12	+[../lwtools-4.14/lwasm/lwasm --list=figao.list figao.asm]
	13	+
	14	+for name in bif-6809lw/*.ASM ; do echo $name :\\n ; cat $name \| tr '\r' '\n' \| grep "BACK" ; done
	15	+
	16	+
	17	+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
	18	+
	19	+
	20	+LOADM "FIG.BIN"
	21	+LOADM"FIG
	22	+EXEC &H1200
	23	+
	24	+
	25	+hex
	26	+
	27	+: bemit dup bl < over 7f < 0= or
	28	+if drop 2e endif
	29	+emit ;
	30	+
	31	+: x.r base @ >r hex .r r> base ! ;
	32	+
	33	+
	34	+: bline
	35	+dup 4 + over do
	36	+i c@ 3 x.r loop
	37	+space space
	38	+dup 4 + swap do
	39	+i c@ bemit loop ;
	40	+
	41	+: bdump cr
	42	+do i 4 x.r 3a emit space
	43	+i bline cr 4 +loop ;
	44	+

--- /dev/null

+++ b/fig-forth-6809_jmp.asm

		@@ -0,0 +1,5869 @@
	1	+ OPT PRT
	2	+
	3	+* fig-FORTH FOR 6809
	4	+* ASSEMBLY SOURCE LISTING
	5	+
	6	+* RELEASE 0
	7	+* JAN-FEB 2019
	8	+* WITH COMPILER SECURITY
	9	+* AND VARIABLE LENGTH NAMES
	10	+* Returning to non-RTS mode
	11	+*
	12	+* Adapted by Joel Matthew Rees
	13	+* from fig-FORTH for 6800 by Dave Lion, et. al.
	14	+
	15	+* This free/libre/open source publication is provided
	16	+* through the courtesy of:
	17	+* FORTH
	18	+* INTEREST
	19	+* GROUP
	20	+* fig
	21	+* and other interested parties.
	22	+
	23	+* Ancient address:
	24	+* P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
	25	+* URL: http://www.forth.org
	26	+* Further distribution must include this notice.
	27	+ PAGE
	28	+ NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
	29	+ OPT NOG,PAG
	30	+* filename fig-forth-auto6809opt.asm
	31	+* === FORTH-6809 {date} {time}
	32	+
	33	+
	34	+* Permission is hereby granted, free of charge, to any person obtaining a copy
	35	+* of this software and associated documentation files (the "Software"), to deal
	36	+* in the Software without restriction, including without limitation the rights
	37	+* to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
	38	+* copies of the Software, and to permit persons to whom the Software is
	39	+* furnished to do so, subject to the following conditions:
	40	+*
	41	+* The above copyright notice and this permission notice shall be included in
	42	+* all copies or substantial portions of the Software.
	43	+
	44	+* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
	45	+* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
	46	+* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
	47	+* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
	48	+* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
	49	+* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
	50	+* THE SOFTWARE.
	51	+*
	52	+* "Associated documentation" for this declaration of license
	53	+* shall be interpreted to include only the comments in this file,
	54	+* or, if the code is split into multiple files,
	55	+* all files containing the complete source.
	56	+*
	57	+* This is the MIT model license, as published by the Open Source Consortium,
	58	+* with associated documentation defined.
	59	+* It was chosen to reflect the spirit of the original
	60	+* terms of use, which used archaic legal terminology.
	61	+*
	62	+
	63	+* Authors of the 6800 model:
	64	+* === Primary: Dave Lion,
	65	+* === with help from
	66	+* === Bob Smith,
	67	+* === LaFarr Stuart,
	68	+* === The Forth Interest Group
	69	+* === PO Box 1105
	70	+* === San Carlos, CA 94070
	71	+* === and
	72	+* === Unbounded Computing
	73	+* === 1134-K Aster Ave.
	74	+* === Sunnyvale, CA 94086
	75	+*
	76	+NATWID EQU 2 ; bytes per natural integer/pointer
	77	+* The original version was developed on an AMI EVK 300 PROTO
	78	+* system using an ACIA for the I/O.
	79	+* This version is developed targeting the Tandy Color Computer.
	80	+
	81	+* All terminal 1/0
	82	+* is done in three subroutines:
	83	+* PEMIT ( word # 182 )
	84	+* PKEY ( 183 )
	85	+* PQTERM ( 184 )
	86	+*
	87	+* The FORTH words for disc related I/O follow the model
	88	+* of the FORTH Interest Group, but have not yet been
	89	+* tested using a real disc.
	90	+*
	91	+* Addresses in the 6800 implementation reflect the fact that,
	92	+* on the development system, it was convenient to
	93	+* write-protect memory at hex 1000, and leave the first
	94	+* 4K bytes write-enabled. As a consequence, code from
	95	+* location $1000 to lable ZZZZ could be put in ROM.
	96	+* Minor deviations from the model were made in the
	97	+* initialization and words ?STACK and FORGET
	98	+* in order to do this.
	99	+* Those deviations will be altered in this
	100	+* implementation for the 6809 -- Color Computer.
	101	+*
	102	+
	103	+* MEMORY MAP for this 16K\|32K system:
	104	+* ( delineated so that systems with 4k byte write-
	105	+* protected segments can write protect FORTH )
	106	+*
	107	+* addr. contents pointer init by
	108	+* ** *************************** *** ****
	109	+*
	110	+* Coco has no ACIA!
	111	+* ACIAC EQU $FBCE the ACIA control address and
	112	+* ACIAD EQU ACIAC+1 data address for PROTO
	113	+*
	114	+MEMT32 EQU $7FFF ; Theoretical absolute end of all ram
	115	+MEMT16 EQU $3FFF ; 16K is too tight until we no longer need disc emulation.
	116	+MEMTOP EQU MEMT32
	117	+*
	118	+MASSHI EQU MEMTOP
	119	+*
	120	+* 3FFF\|7FFF HI
	121	+*
	122	+* substitute for disc mass memory
	123	+RAMSCR EQU 8 ; addresses calculate as 2 (Too much for 16K in RAM only.)
	124	+SCRSZ EQU 1024
	125	+* 3800\|7800 LO
	126	+MASSLO EQU MASSHI-RAMSCR*SCRSZ+1
	127	+RAMDSK EQU MASSLO
	128	+MEMEND EQU MASSLO
	129	+*
	130	+* 3800\|7800 MEMEND
	131	+* "end" of "usable ram" (If disc mass memory emulation is removed, actual end.)
	132	+*
	133	+* 37FF\|77FF
	134	+*
	135	+* per-user tables
	136	+USERSZ EQU 256 ; (Addressable by DP, must be 256 on even boundary)
	137	+USER16 EQU 1 ; We can change these for ROMPACK or 64K.
	138	+USER32 EQU 2 ; maybe?
	139	+USERCT EQU USER32
	140	+USERLO EQU MEMEND-USERSZ*USERCT
	141	+IUP EQU USERLO
	142	+IUPDP EQU IUP/256
	143	+* user tables of variables
	144	+* registers & pointers for the virtual machine
	145	+* scratch area for potential use in something, maybe?
	146	+*
	147	+* 3700\|7600 <== UP
	148	+*
	149	+* This is a really awkward place to define the disk buffer records.
	150	+*
	151	+* 4 buffer sectors of VIRTUAL MEMORY
	152	+NBLK EQU 4 ; # of disc buffer blocks for virtual memory
	153	+* Should NBLK be SCRSZ/SECTSZ?
	154	+* each block is SECTSZ+SECTRL bytes in size,
	155	+* holding SECTSZ characters
	156	+SECTSZ EQU 256
	157	+SECTRL EQU 2*NATWID ; Currently held sector number, etc.
	158	+BUFSZ EQU (SECTSZ+SECTRL)*NBLK
	159	+BUFBAS EQU USERLO-BUFSZ
	160	+* BUG SECTRL is hard-wired into several definitions.
	161	+* It will take a bit of work to ferret them out.
	162	+* It is too small, and it should not be hard-wired.
	163	+* SECTSZ was also hard-wired into several definitions,
	164	+* will I find them all?
	165	+*
	166	+* 32E0\|71E0 FIRST
	167	+*
	168	+ PAGE
	169	+*
	170	+* Don't want one return too many to destroy the disc buffers.
	171	+RPBUMP EQU 4*NATWID
	172	+*
	173	+* 32D8\|71D8 <== RP RINIT
	174	+*
	175	+IRP EQU BUFBAS-RPBUMP
	176	+* RETURN STACK
	177	+RSTK16 EQU $50*NATWID ; 80 max levels nesting calls
	178	+RSTK32 EQU $90*NATWID ; 144 max
	179	+RSTKSZ EQU RSTK32
	180	+*
	181	+* 3248\|70B8
	182	+*
	183	+SFTBND EQU IRP-RSTKSZ ; (false boundary between TIB and return stack)
	184	+* INPUT LINE BUFFER
	185	+* holds up to TIBSZ characters
	186	+* and is scanned upward by IN
	187	+* starting at TIB
	188	+TIBSZ EQU 256
	189	+ITIB EQU SFTBND-TIBSZ
	190	+*
	191	+* 3148\|6FB8 <== IN TIB
	192	+*
	193	+* Don't want terminal input and parameter underflow collisions
	194	+SPBUMP EQU 4*NATWID
	195	+*
	196	+ISP EQU ITIB-SPBUMP
	197	+*
	198	+* 3140\|6FB0 <== SP SP0,SINIT
	199	+* DATA STACK
	200	+* \| grows downward from 3140\|6FB0
	201	+* v
	202	+* - -
	203	+* ^
	204	+* \|
	205	+* I DICTIONARY grows upward
	206	+*
	207	+* >>>>>>--------Two words to start RAMmable dictionary--------<<<<<<
	208	+*
	209	+* (2B00)
	210	+* ???? end of ram-dictionary. <== DICTPT DPINIT
	211	+* "TASK"
	212	+*
	213	+* ???? "FORTH" ( a word ) <=, <== CONTEXT
	214	+* `==== CURRENT
	215	+* start of ram-dictionary.
	216	+*
	217	+* >>>>>> memory from here up must be in RAM area <<<<<<
	218	+*
	219	+* ????
	220	+* 6k of romable "FORTH" <== IP ABORT
	221	+* <== W
	222	+* the VIRTUAL FORTH MACHINE
	223	+*
	224	+* 1208 initialization tables
	225	+* 1204 <<< WARM START ENTRY >>>
	226	+* 1200 <<< COLD START ENTRY >>>
	227	+* 1200 lowest address used by FORTH
	228	+*
	229	+CODEBG EQU $1200
	230	+* CODEBG EQU $3000
	231	+*
	232	+* >>>>>> memory from here down left alone <<<<<<
	233	+* >>>>>> so we can safely call ROM routines <<<<<<
	234	+*
	235	+* 0000
	236	+ PAGE
	237	+***
	238	+*
	239	+* CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
	240	+*
	241	+* IP (hardware Y) points to the current instruction ( pre-increment mode )
	242	+* RP (hardware S) points to last return address pushedin return stack
	243	+* SP (hardware U) points to last byte pushed in data stack
	244	+*
	245	+* Y must be IP when NEXT is entered (if using the inner loop).
	246	+*
	247	+* When A and B hold one 16 bit FORTH data word,
	248	+* A contains the high byte, B, the low byte.
	249	+*
	250	+* UP (hardware DP) is the base of per-task ("user") variables.
	251	+* (Be careful of the stray semantics of "user".)
	252	+*
	253	+* W (hardware X) is the pointer to the "code field" address of native CPU
	254	+* machine code to be executed for the definition of the dictionary word
	255	+* to be executed/currently executing.
	256	+* The following natural integer (word) begins any "parameter section"
	257	+* (body) -- similar to a "this" pointer, but not the same.
	258	+* It may be native CPU machine code, or it may be a global variable,
	259	+* or it may be a list of Forth definition words (addresses).
	260	+*
	261	+* ======
	262	+* This implementation uses the native subroutine architecture
	263	+* rather than a postponed-push call that the 6800 model VM uses
	264	+* to save code and time in leaf routines.
	265	+*
	266	+* This should allow directly calling many of the Forth words
	267	+* from assembly language code.
	268	+* (Be aware of the need for a valid W in some cases.)
	269	+* It won't allow mixing assembly language directly into Forth word lists.
	270	+* ======
	271	+*
	272	+* boolean flags:
	273	+* 0 is false, anything else is true.
	274	+* Most places in this model that set a boolean flag set true as 1.
	275	+* This is in contrast to many models that set a boolean flag as -1.
	276	+*
	277	+***
	278	+
	279	+ PAGE
	280	+* This system is shown with one user (task),
	281	+* but additional users (tasks) may be added
	282	+* by allocating additional user tables:
	283	+*
	284	+ ORG IUP
	285	+UBASE RMB USERSZ
	286	+UBASEX RMB USERSZ data table for extra users
	287	+*
	288	+* Some of this stuff gets initialized during
	289	+* COLD start and WARM start:
	290	+* [ names correspond to FORTH words of similar (no X) name ]
	291	+*
	292	+ ORG IUP
	293	+UORIG EQU *
	294	+* A few useful VM variables
	295	+* Will be removed when they are no longer needed.
	296	+* All are replaced by 6809 registers.
	297	+
	298	+N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
	299	+* SP@,SWAP,DOES>,COLD
	300	+
	301	+
	302	+* These locations are used by the TRACE routine :
	303	+
	304	+TRLIM RMB 1 the count for tracing without user intervention
	305	+TRACEM RMB 1 non-zero = trace mode
	306	+BRKPT RMB 2 the breakpoint address at which
	307	+* the program will go into trace mode
	308	+VECT RMB 2 vector to machine code
	309	+* (only needed if the TRACE routine is resident)
	310	+
	311	+
	312	+* Registers used by the FORTH virtual machine:
	313	+* Starting at $OOFO:
	314	+
	315	+
	316	+W RMB 2 the instruction register points to 6800 code
	317	+* This is not exactly accurate. Points to the definiton body,
	318	+* which is native CPU machine code when it is native CPU machine code.
	319	+* IP RMB 2 the instruction pointer points to pointer to 6800 code
	320	+* RP RMB 2 the return stack pointer
	321	+* UP RMB 2 the pointer to base of current user's 'USER' table
	322	+* ( altered during multi-tasking )
	323	+*
	324	+*UORIG RMB 6 3 reserved variables
	325	+ RMB 6 3 reserved variables
	326	+XSPZER RMB 2 initial top of data stack for this user
	327	+XRZERO RMB 2 initial top of return stack
	328	+XTIB RMB 2 start of terminal input buffer
	329	+XWIDTH RMB 2 name field width
	330	+XWARN RMB 2 warning message mode (0 = no disc)
	331	+XFENCE RMB 2 fence for FORGET
	332	+XDICTP RMB 2 dictionary pointer
	333	+XVOCL RMB 2 vocabulary linking
	334	+XBLK RMB 2 disc block being accessed
	335	+XIN RMB 2 scan pointer into the block
	336	+XOUT RMB 2 cursor position
	337	+XSCR RMB 2 disc screen being accessed ( O=terminal )
	338	+XOFSET RMB 2 disc sector offset for multi-disc
	339	+XCONT RMB 2 last word in primary search vocabulary
	340	+XCURR RMB 2 last word in extensible vocabulary
	341	+XSTATE RMB 2 flag for 'interpret' or 'compile' modes
	342	+XBASE RMB 2 number base for I/O numeric conversion
	343	+XDPL RMB 2 decimal point place
	344	+XFLD RMB 2
	345	+XCSP RMB 2 current stack position, for compile checks
	346	+XRNUM RMB 2
	347	+XHLD RMB 2
	348	+XDELAY RMB 2 carriage return delay count
	349	+XCOLUM RMB 2 carriage width
	350	+IOSTAT RMB 2 last acia status from write/read
	351	+ RMB 2 ( 4 spares! )
	352	+ RMB 2
	353	+ RMB 2
	354	+ RMB 2
	355	+
	356	+
	357	+
	358	+
	359	+*
	360	+*
	361	+* end of user table, start of common system variables
	362	+*
	363	+*
	364	+* These need to be moved to where they will be
	365	+* initialized globals in variable space, not in the USER table.
	366	+* Or, more accurately, need to be turned into monitored or semaphored resources.
	367	+XUSE RMB 2
	368	+XPREV RMB 2
	369	+ RMB 4 ( spares )
	370	+
	371	+ PAGE
	372	+* The FORTH program ( address $1200 to about $27FF ) will be written
	373	+* so that it can be in a ROM, or write-protected if desired,
	374	+* but right now we're just getting it running.
	375	+ ORG CODEBG
	376	+
	377	+* ######>> screen 3 <<
	378	+*
	379	+***************************
	380	+ C O L D E N T R Y
	381	+***************************
	382	+ORIG NOP
	383	+* JMP CENT
	384	+ LBRA CENT
	385	+***************************
	386	+ W A R M E N T R Y
	387	+***************************
	388	+ NOP
	389	+* JMP WENT warm-start code, keeps current dictionary intact
	390	+ LBRA WENT warm-start code, keeps current dictionary intact
	391	+ SETDP IUPDP
	392	+
	393	+*
	394	+***** startup parmeters ************************
	395	+*
	396	+ FDB $6809,0000 cpu & revision
	397	+ FDB 0 topmost word in FORTH vocabulary
	398	+* BACKSP FDB $7F backspace character for editing
	399	+BACKSP FDB $08 backspace character for editing
	400	+UPINIT FDB UORIG initial user area
	401	+* UPINIT FDB UORIG initial user area
	402	+SINIT FDB ISP ; initial top of data stack
	403	+* SINIT FDB ORIG-$D0 initial top of data stack
	404	+RINIT FDB IRP ; initial top of return stack
	405	+* RINIT FDB ORIG-2 initial top of return stack
	406	+ FDB ITIB ; terminal input buffer
	407	+* FDB ORIG-$D0 terminal input buffer
	408	+ FDB 31 initial name field width
	409	+ FDB 0 initial warning mode (0 = no disc)
	410	+FENCIN FDB REND initial fence
	411	+DPINIT FDB REND cold start value for DICTPT
	412	+BUFINT FDB BUFBAS Start of the disk buffers area
	413	+VOCINT FDB FORTH+4*NATWID
	414	+COLINT FDB TIBSZ initial terminal carriage width
	415	+DELINT FDB 4 initial carriage return delay
	416	+****************************************************
	417	+*
	418	+ PAGE
	419	+*
	420	+* ######>> screen 13 <<
	421	+* These were of questionable use anyway,
	422	+* kept here now to satisfy the assembler and show hints.
	423	+* They're too much trouble to use with native subroutine call anyway.
	424	+* PULABX PULS A ; 24 cycles until 'NEXT'
	425	+* PULS B ;
	426	+* PULABX PULU A,B ; ?? cycles until 'NEXT'
	427	+* STABX STA 0,X 16 cycles until 'NEXT'
	428	+* STB 1,X
	429	+* STABX STD 0,X ; ?? cycles until 'NEXT'
	430	+* BRA NEXT
	431	+* GETX LDA 0,X 18 cycles until 'NEXT'
	432	+* LDB 1,X
	433	+* GETX LDD 0,X ?? cycles until 'NEXT'
	434	+* PUSHBA PSHS B ; 8 cycles until 'NEXT'
	435	+* PSHS A ;
	436	+* PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
	437	+
	438	+
	439	+*
	440	+* "NEXT" takes ?? cycles if TRACE is removed,
	441	+*
	442	+* and ?? cycles if trace is present and NOT tracing.
	443	+*
	444	+* = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
	445	+* =
	446	+* NEXT itself might just completely go away.
	447	+* About the only reason to keep it is to allowing executing a list
	448	+* which allows a cheap TRACE routine.
	449	+*
	450	+* NEXT is a loop which implements the Forth VM.
	451	+* It basically cycles through calling the code out of code lists,
	452	+* one at a time.
	453	+* Using a native CPU return for this uses a few extra cycles per call,
	454	+* compared to simply jumping to each definition and jumping back
	455	+* to the known beginning of the loop,
	456	+* but the loop itself is really only there for convenience.
	457	+*
	458	+* This implementation uses the native subroutine call,
	459	+* to break the wall between Forth code and non-Forth code.
	460	+*
	461	+* NEXT LDX IP
	462	+* LEAX 1,X ; pre-increment mode
	463	+* LEAX 1,X ;
	464	+* STX IP
	465	+NEXT ; IP is Y, push before using, pull before you come back here.
	466	+*
	467	+* NEXT2 LDX 0,X get W which points to CFA of word to be done
	468	+NEXT2 LDX ,Y++ get W which points to CFA of word to be done
	469	+ BSR DBGNAM
	470	+ BSR DBGREG
	471	+* But NEXT2 is too much trouble to use with subroutine threading anyway.
	472	+* NEXT3 STX W
	473	+NEXT3 ; W is X until you use X for something else. (TOS points back here.)
	474	+* But NEXT3 is too much trouble to use with subroutine threading anyway.
	475	+* LDX 0,X get VECT which points to executable code
	476	+* =
	477	+* The next instruction could be patched to JMP TRACE =
	478	+* if a TRACE routine is available: =
	479	+* =
	480	+* JMP 0,X
	481	+
	482	+ JMP [,X] ; Saving the postinc cycles,
	483	+* ; but X must be bumped NATWID to the parameters.
	484	+* NOP
	485	+* JMP TRACE ( an alternate for the above )
	486	+* BSR DBGREG ( an alternate for the above )
	487	+* In other words, with the call and the NOP,
	488	+* there is room to patch the call with a JMP to your TRACE
	489	+* routine, which you have to provide.
	490	+ BRA NEXT
	491	+*
	492	+DBGNAM PSHS CC,D,X,Y
	493	+ TST <TRACEM
	494	+ BEQ DBGNrt
	495	+ LEAX -3,X
	496	+DBGNlf LDB ,-X
	497	+ BPL DBGNlf
	498	+ LDY #$4C0
	499	+ LDB ,X+
	500	+DBGNlp LDB ,X+
	501	+ BMI DBGNll
	502	+ STB ,Y+
	503	+ BRA DBGNlp
	504	+DBGNll ANDB #$7F
	505	+ STB ,Y+
	506	+ LDB #$60
	507	+ BRA DBGNlt
	508	+DBGNlc STB ,Y+
	509	+DBGNlt CMPY #$4E0
	510	+ BLO DBGNlc
	511	+DBGNrt PULS CC,D,X,Y,PC
	512	+*
	513	+*
	514	+MKhxBh LSRB
	515	+ LSRB
	516	+ LSRB
	517	+ LSRB
	518	+MKhxBl ANDB #$0F
	519	+ ADDB #$30
	520	+ CMPB #$39
	521	+ BLS MKhxBx
	522	+ ADDB #$C7 ; ($40-$39)-$40
	523	+MKhxBx RTS
	524	+*
	525	+OUThxA EXG A,B
	526	+ BSR OUThxB
	527	+ EXG A,B
	528	+ RTS
	529	+*
	530	+OUThxD BSR OUThxA
	531	+OUThxB PSHS B
	532	+ BSR MKhxBh
	533	+ STB ,X+
	534	+ LDB ,S
	535	+ BSR MKhxBl
	536	+ STB ,X+
	537	+ PULS B,PC
	538	+*
	539	+DBGREG PSHS U,Y,X,DP,B,A,CC
	540	+ TST <TRACEM
	541	+ LBEQ DBGRrt
	542	+ LEAY DBGRLB,PCR
	543	+ LDX #$4E0
	544	+DBGRlp LDD ,Y++
	545	+ BEQ DBGRdn
	546	+ STD ,X++
	547	+ BRA DBGRlp
	548	+DBGRdn LDX #$500
	549	+ LDA 3,S ; DP
	550	+ LDB ,S ; CC
	551	+ BSR OUThxD
	552	+ LDB #$60
	553	+ STB ,X+
	554	+ LDD 3*NATWID+4,S ; PC:505
	555	+ BSR OUThxD
	556	+ LDB #$60
	557	+ STB ,X+
	558	+ TFR S,D ; 509
	559	+ ADDD #4*NATWID+4
	560	+ BSR OUThxD
	561	+ LDD 2*NATWID+4,S ; U:50E
	562	+ BSR OUThxD
	563	+ LDB #$60
	564	+ STB ,X+
	565	+ LDD 1*NATWID+4,S ; Y:513
	566	+ BSR OUThxD
	567	+ LDD 0*NATWID+4,S ; X at 517
	568	+ BSR OUThxD
	569	+ LDB #$60
	570	+ STB ,X+
	571	+ LDD 1,S ; D at 51C
	572	+ BSR OUThxD
	573	+ LDB #$60
	574	+ STB ,X+
	575	+ STB ,X+
	576	+ STB ,X+
	577	+ STB ,X+
	578	+ STB ,X+
	579	+ LDD [3*NATWID+4,S] ; PC
	580	+ BSR OUThxD
	581	+ LDB #$60
	582	+ STB ,X+
	583	+ LDD 4*NATWID+4,S ; S
	584	+ BSR OUThxD
	585	+ LDD [2*NATWID+4,S] ; U
	586	+ BSR OUThxD
	587	+ LDB #$60
	588	+ STB ,X+
	589	+ LDD [1*NATWID+4,S] ; Y
	590	+ LBSR OUThxD
	591	+ LDD [0*NATWID+4,S] ; X
	592	+ LBSR OUThxD
	593	+ LDB #$60
	594	+ STB ,X+
	595	+ STB ,X+
	596	+ STB ,X+
	597	+ STB ,X+
	598	+ STB ,X+
	599	+ LDB #0
	600	+ EXG B,DP
	601	+DBGRkl JSR [$A000]
	602	+ BEQ DBGRkl
	603	+ STD $43E
	604	+ EXG DP,B
	605	+ CMPA #$55 ; 'U'
	606	+ BEQ DBGRdU
	607	+ CMPA #$53 ; 'S'
	608	+ BEQ DBGRdS
	609	+ CMPA #$49 ; 'I'
	610	+ LBNE DBGRrt
	611	+DBGRin LDD <XTIB
	612	+ ADDD <XIN
	613	+ TFR D,Y
	614	+ LBSR OUThxD
	615	+ LDB #$3a ; ':'
	616	+ STB ,X+
	617	+ LDA <XCOLUM
	618	+DBGRip LDB ,Y+
	619	+ STB ,X+
	620	+ BEQ DBGRrt
	621	+DBGRit DECA
	622	+ BNE DBGRip
	623	+ BRA DBGRrt
	624	+DBGRdS TFR S,Y
	625	+ LDD ,Y++
	626	+ LBSR OUThxA
	627	+ LDA #$9F
	628	+ STA ,X+
	629	+ LBSR OUThxB
	630	+ LDD ,Y++
	631	+ LBSR OUThxA
	632	+ LDA #$9F
	633	+ STA ,X+
	634	+ LBSR OUThxB
	635	+ LDA #$58 ; X
	636	+ STA ,X+
	637	+ LDD ,Y++
	638	+ LBSR OUThxD
	639	+ LDA #$59 ; Y
	640	+ STA ,X+
	641	+ LDD ,Y++
	642	+ LBSR OUThxD
	643	+ LDA #$55 ; U
	644	+ STA ,X+
	645	+ LDD ,Y++
	646	+ LBSR OUThxD
	647	+ LDA #$50 ; PC
	648	+ STA ,X+
	649	+ LDD ,Y++
	650	+ LBSR OUThxD
	651	+ LDA #$53 ; Stack
	652	+ STA ,X+
	653	+ BRA DBGRst
	654	+DBGRsp LDD ,Y++
	655	+ LBSR OUThxD
	656	+ LDB #$60
	657	+ STB ,X+
	658	+DBGRst CMPY <XRZERO
	659	+ BLO DBGRsp
	660	+ LDB #$3a ; ':'
	661	+ STB ,X+
	662	+ LDB #$55
	663	+ STB ,X+
	664	+DBGRdU LDY 2*NATWID+4,S
	665	+ BRA DBGRut
	666	+DBGRup LDD ,Y++
	667	+ LBSR OUThxD
	668	+ LDB #$60
	669	+ STB ,X+
	670	+DBGRut CMPY <XSPZER
	671	+ BLO DBGRup
	672	+ LDB #$FF
	673	+ STB ,X+
	674	+DBGRrt PULS CC,A,B,DP,X,Y,U,PC
	675	+DBGRLB FCC 'DPCC PC S U Y X A B '
	676	+ FDB 0,0
	677	+
	678	+
	679	+*
	680	+* =
	681	+* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
	682	+
	683	+
	684	+ PAGE
	685	+*
	686	+* ======>> 1 <<
	687	+* ( --- n )
	688	+* Pushes the following natural width integer from the instruction stream
	689	+* as a literal, or immediate value.
	690	+*
	691	+* FDB {OP}
	692	+* FDB {OP}
	693	+* FDB LIT
	694	+* FDB LITERAL-TO-BE-PUSHED
	695	+* FDB {OP}
	696	+*
	697	+* In native processor code, there should be a better way, use that instead.
	698	+* More specifically, DO NOT CALL THIS from assembly language code.
	699	+* (Note that there is no compile-only flag in the fig model.)
	700	+*
	701	+* See (FIND), or PFIND , for layout of the header format.
	702	+*
	703	+ FCB $83
	704	+ FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
	705	+ FCB $D4 ; 'T'\|'\x80' ; character code for T, with high bit set.
	706	+ FDB 0 ; link of zero to terminate dictionary scan
	707	+LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
	708	+ LDD ,Y++
	709	+ PSHU A,B
	710	+ LBRA NEXT
	711	+* LDX IP
	712	+* LEAX 1,X ;
	713	+* LEAX 1,X ;
	714	+* STX IP
	715	+* LDA 0,X
	716	+* LDB 1,X
	717	+* JMP PUSHBA
	718	+*
	719	+* ######>> screen 14 <<
	720	+* ======>> 2 <<
	721	+* ( --- n )
	722	+* Pushes the following byte from the instruction stream
	723	+* as a literal, or immediate value.
	724	+*
	725	+* FDB {OP}
	726	+* FDB {OP}
	727	+* FDB LIT8
	728	+* FCB LITERAL-TO-BE-PUSHED
	729	+* FDB {OP}
	730	+*
	731	+* If this is kept, it should have a header for TRACE to read.
	732	+* If the data bus is wider than a byte, you don't want to do this.
	733	+* Byte shaving like this is often counter-productive anyway.
	734	+* Changing the name to LIT8, hoping that will be more understandable.
	735	+* Also, see comments for LIT.
	736	+* (Note that there is no compile-only flag in the fig model.)
	737	+ FCB $84
	738	+ FCC 'LIT' ; 'LIT8' : NOTE: this is different from LITERAL
	739	+ FCB $B8
	740	+ FDB LIT-6
	741	+LIT8 FDB *+NATWID (this was an invisible word, with no header)
	742	+ LDB ,Y+ ; This also is meaningless in native code.
	743	+ CLRA
	744	+ PSHU A,B
	745	+ LBRA NEXT
	746	+* LDX IP
	747	+* LEAX 1,X ;
	748	+* STX IP
	749	+* CLRA ;
	750	+* LDB 1,X
	751	+* JMP PUSHBA
	752	+*
	753	+* ( n off --- n )
	754	+* off is offset in video buffer area.
	755	+ FCB $87
	756	+ FCC 'SHOWTO' ; 'SHOWTOS'
	757	+ FCB $D3 ; 'S'
	758	+ FDB LIT8-7
	759	+SHOTOS FDB *+NATWID
	760	+ LDX #$400
	761	+ LDD ,U++
	762	+ LEAX D,X
	763	+ LDD ,U
	764	+ LBSR OUThxD
	765	+ JMP NEXT
	766	+*
	767	+ FCB $85
	768	+ FCC 'TROF' ; 'TROFF'
	769	+ FCB $C6 ; 'F'\|$80
	770	+ FDB SHOTOS-10
	771	+TROFF FDB *+NATWID
	772	+ CLR <TRACEM
	773	+ JMP NEXT
	774	+*
	775	+ FCB $84
	776	+ FCC 'TRO' ; 'TRON'
	777	+ FCB $CE ; 'N'\|$80
	778	+ FDB TROFF-8
	779	+TRON FDB *+NATWID
	780	+ INC <TRACEM
	781	+ JMP NEXT
	782	+*
	783	+* ======>> 3 <<
	784	+* ( adr --- )
	785	+* Jump to address on stack. Used by the "outer" interpreter to
	786	+* interactively invoke routines.
	787	+* Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
	788	+ FCB $87
	789	+ FCC 'EXECUT' ; 'EXECUTE'
	790	+ FCB $C5
	791	+ FDB TRON-7
	792	+EXEC FDB *+NATWID
	793	+ PULU X ; Gotta have W anyway, just in case.
	794	+ JMP [,X] ; Tail return.
	795	+* TFR S,X ; TSX :
	796	+* LDX 0,X get code field address (CFA)
	797	+* LEAS 1,S ; pop stack
	798	+* LEAS 1,S ;
	799	+* JMP NEXT3
	800	+*
	801	+* ######>> screen 15 <<
	802	+* ======>> 4 <<
	803	+* ( --- ) C
	804	+* Add the following word from the instruction stream to the
	805	+* instruction pointer (Y++). Causes a program branch in Forth code stream.
	806	+*
	807	+* In native processor code, there should be a better way, use that instead.
	808	+* More specifically, DO NOT CALL THIS from assembly language code.
	809	+* This is only for Forth code stream.
	810	+* Also, see comments for LIT.
	811	+ FCB $86
	812	+ FCC 'BRANC' ; 'BRANCH'
	813	+ FCB $C8
	814	+ FDB EXEC-10
	815	+BRAN FDB ZBYES ; Go steal code in ZBRANCH
	816	+
	817	+* Moving code around to optimize the branch taking case in 0BRANCH.
	818	+ZBNO LEAY NATWID,Y ; No branch.
	819	+ JMP NEXT
	820	+* ======>> 5 <<
	821	+* ( f --- ) C
	822	+* BRANCH if flag is zero.
	823	+*
	824	+* In native processor code, there should be a better way, use that instead.
	825	+* More specifically, DO NOT CALL THIS from assembly language code.
	826	+* This is only for Forth code stream.
	827	+* Also, see comments for LIT.
	828	+ FCB $87
	829	+ FCC '0BRANC' ; '0BRANCH'
	830	+ FCB $C8
	831	+ FDB BRAN-9
	832	+ZBRAN FDB *+NATWID
	833	+ LDD ,U++
	834	+ BNE ZBNO
	835	+ZBYES LDD ,Y++
	836	+ LEAY D,Y ; IP is postinc
	837	+ JMP NEXT
	838	+* PULS A ;
	839	+* PULS B ;
	840	+* PSHS B ; ** emulating ABA:
	841	+* ADDA ,S+ ;
	842	+* BNE ZBNO
	843	+* BCS ZBNO
	844	+* ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
	845	+* LDB 3,X
	846	+* LDA 2,X
	847	+* ADDB IP+1
	848	+* ADCA IP
	849	+* STB IP+1
	850	+* STA IP
	851	+* JMP NEXT
	852	+* ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
	853	+* LEAX 1,X ; jump over branch delta
	854	+* LEAX 1,X ;
	855	+* STX IP
	856	+* JMP NEXT
	857	+*
	858	+* ######>> screen 16 <<
	859	+
	860	+***** Continue from the LOOP variables ******
	861	+
	862	+
	863	+* ======>> 6 <<
	864	+* ( --- ) ( limit index *** limit index+1) C
	865	+* ( limit index *** )
	866	+* Counting loop primitive. The counter and limit are the top two
	867	+* words on the return stack. If the updated index/counter does
	868	+* not exceed the limit, a branch occurs. If it does, the branch
	869	+* does not occur, and the index and limit are dropped from the
	870	+* return stack.
	871	+*
	872	+* In native processor code, there should be a better way, use that instead.
	873	+* More specifically, DO NOT CALL THIS from assembly language code.
	874	+* This is only for Forth code stream.
	875	+* Also, see comments for LIT.
	876	+ FCB $86
	877	+ FCC '(LOOP' ; '(LOOP)'
	878	+ FCB $A9
	879	+ FDB ZBRAN-10
	880	+XLOOP FDB *+NATWID
	881	+ LDD #1 ; Borrowing from BIF-6809.
	882	+XLOOPA ADDD ,S ; No return address to dodge.
	883	+ STD ,S
	884	+ SUBD NATWID,S
	885	+ BMI ZBYES ; pseudo-signed-unsigned
	886	+XLOOPN LEAY NATWID,Y
	887	+ LEAS 2*NATWID,S ; Clean up the index and limit.
	888	+ LBRA NEXT
	889	+* CLRA ;
	890	+* LDB #1 get set to increment counter by 1 (Clears N.)
	891	+* BRA XPLOP2 go steal other guy's code!
	892	+*
	893	+* ======>> 7 <<
	894	+* ( n --- ) ( limit index *** limit index+n ) C
	895	+* ( limit index *** )
	896	+* Loop with a variable increment. Terminates when the index
	897	+* crosses the boundary from one below the limit to the limit. A
	898	+* positive n will cause termination if the result index equals the
	899	+* limit. A negative n must cause the index to become less than
	900	+* the limit to cause loop termination.
	901	+*
	902	+* Note that the end conditions are not symmetric around zero.
	903	+*
	904	+* In native processor code, there should be a better way, use that instead.
	905	+* More specifically, DO NOT CALL THIS from assembly language code.
	906	+* This is only for Forth code stream.
	907	+* Also, see comments for LIT.
	908	+ FCB $87
	909	+ FCC '(+LOOP' ; '(+LOOP)'
	910	+ FCB $A9
	911	+ FDB XLOOP-9
	912	+XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
	913	+ LDD ,U++ ; inc val
	914	+ BPL XLOOPA ; Steal plain loop code for forward count.
	915	+ ADDD ,S ; No return address to dodge
	916	+ STD ,S
	917	+ SUBD NATWID,S
	918	+ BPL ZBYES ; pseudo-signed-unsigned
	919	+ BRA XLOOPN ; This path might be less time-sensitive.
	920	+*
	921	+* This should work, but I want to use tested code.
	922	+* PULU A,B ; Get the increment.
	923	+* XPLOP2 PULS X ; Pre-clear the return stack.
	924	+* PSHU A ; Save the direction in high bit.
	925	+* ADDD ,S ; Count.
	926	+* STD ,S ; Update.
	927	+* SUBD NATWID,S ; Check limit.
	928	+**
	929	+** I think this should work:
	930	+* EORA ,U+ ; dir < 0 and (count - limit) >= 0
	931	+* BPL XPLONO ; or dir >= 0 and (count - limit) < 0
	932	+* LDD ,Y++
	933	+* LEAY D,Y ; IP is postinc
	934	+* JMP ,X
	935	+* XPLONO LEAS 2*NATWID,S
	936	+* JMP ,X ; synthetic return
	937	+*
	938	+* This definitely should work:
	939	+* TST ,U+ ; Get the sign
	940	+* BPL XPLOF ;
	941	+* CMPD NATWID,S
	942	+* BMI XPLONO
	943	+* XPLOYE LDD ,Y++
	944	+* LEAY D,Y ; IP is postinc
	945	+* JMP ,X
	946	+* XPLOF CMPD NATWID,S
	947	+* BMI XPLOYE
	948	+* XPLONO LEAS 2*NATWID,S
	949	+* JMP ,X ; synthetic return
	950	+*
	951	+* 6800 Probably could have used the exclusive-or method, too.:
	952	+* PULS A ; get increment
	953	+* PULS B ;
	954	+* XPLOP2 TSTA ;
	955	+* BPL XPLOF forward looping
	956	+* BSR XPLOPS
	957	+* ORCC #$01 ; SEC :
	958	+* SBCB 5,X
	959	+* SBCA 4,X
	960	+* BPL ZBYES
	961	+* BRA XPLONO fall through
	962	+*
	963	+* the subroutine :
	964	+* XPLOPS LDX RP
	965	+* ADDB 3,X add it to counter
	966	+* ADCA 2,X
	967	+* STB 3,X store new counter value
	968	+* STA 2,X
	969	+* RTS
	970	+*
	971	+* XPLOF BSR XPLOPS
	972	+* SUBB 5,X
	973	+* SBCA 4,X
	974	+* BMI ZBYES
	975	+*
	976	+* XPLONO LEAX 1,X ; done, don't branch back
	977	+* LEAX 1,X ;
	978	+* LEAX 1,X ;
	979	+* LEAX 1,X ;
	980	+* STX RP
	981	+* BRA ZBNO use ZBRAN to skip over unused delta
	982	+*
	983	+* ######>> screen 17 <<
	984	+* ======>> 8 <<
	985	+* ( limit index --- ) ( *** limit index )
	986	+* Move the loop parameters to the return stack. Synonym for D>R.
	987	+ FCB $84
	988	+ FCC '(DO' ; '(DO)'
	989	+ FCB $A9
	990	+ FDB XPLOOP-10
	991	+XDO FDB *+NATWID This is the RUNTIME DO, not the COMPILING DO
	992	+ PULU D,X
	993	+ PSHS D,X ; Ends up same order.
	994	+ LBRA NEXT ; No return address to mess with.
	995	+*
	996	+* LDX RP
	997	+* LEAX -1,X ;
	998	+* LEAX -1,X ;
	999	+* LEAX -1,X ;
	1000	+* LEAX -1,X ;
	1001	+* STX RP
	1002	+* PULS A ;
	1003	+* PULS B ;
	1004	+* STA 2,X
	1005	+* STB 3,X
	1006	+* PULS A ;
	1007	+* PULS B ;
	1008	+* STA 4,X
	1009	+* STB 5,X
	1010	+* JMP NEXT
	1011	+*
	1012	+* ======>> 9 <<
	1013	+* ( --- index ) ( limit index *** limit index )
	1014	+* Copy the loop index from the return stack. Synonym for R.
	1015	+ FCB $81 I
	1016	+ FCB $C9
	1017	+ FDB XDO-7
	1018	+I FDB *+NATWID
	1019	+ LDD ,S ; No return address to dodge.
	1020	+ PSHU D
	1021	+ LBRA NEXT
	1022	+* LDX RP
	1023	+* LEAX 1,X ;
	1024	+* LEAX 1,X ;
	1025	+* JMP GETX
	1026	+*
	1027	+* ######>> screen 18 <<
	1028	+* ======>> 10 <<
	1029	+* ( c base --- false )
	1030	+* ( c base --- n true )
	1031	+* Translate C in base, yielding a translation valid flag. If the
	1032	+* translation is not valid in the specified base, only the false
	1033	+* flag is returned.
	1034	+ FCB $85
	1035	+ FCC 'DIGI' ; 'DIGIT'
	1036	+ FCB $D4
	1037	+ FDB I-4
	1038	+DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
	1039	+ LDD NATWID,U ; Check the whole thing.
	1040	+ SUBD #$30 ; ascii zero
	1041	+ BMI DIGIT2 IF LESS THAN '0', ILLEGAL
	1042	+ CMPD #$A
	1043	+ BMI DIGIT0 IF '9' OR LESS
	1044	+ CMPD #$11
	1045	+ BMI DIGIT2 if less than 'A'
	1046	+ CMPD #$2B
	1047	+ BPL DIGIT2 if greater than 'Z'
	1048	+ SUBD #7 translate 'A' thru 'F'
	1049	+DIGIT0 CMPD ,U ; Check the base.
	1050	+ BPL DIGIT2 if not less than the base
	1051	+ STD NATWID,U ; Store converted digit. (High byte known zero.)
	1052	+ LDD #1 ; set valid flag
	1053	+DIGIT1 STD ,U ; store the flag
	1054	+ LBRA NEXT
	1055	+DIGIT2 LDD #0 ; set not valid flag
	1056	+ LEAU NATWID,U ; pop base
	1057	+ BRA DIGIT1
	1058	+* TFR S,X ; TSX :
	1059	+* LDA 3,X
	1060	+* SUBA #$30 ascii zero
	1061	+* BMI DIGIT2 IF LESS THAN '0', ILLEGAL
	1062	+* CMPA #$A
	1063	+* BMI DIGIT0 IF '9' OR LESS
	1064	+* CMPA #$11
	1065	+* BMI DIGIT2 if less than 'A'
	1066	+* CMPA #$2B
	1067	+* BPL DIGIT2 if greater than 'Z'
	1068	+* SUBA #7 translate 'A' thru 'F'
	1069	+* DIGIT0 CMPA 1,X
	1070	+* BPL DIGIT2 if not less than the base
	1071	+* LDB #1 set flag
	1072	+* STA 3,X store digit
	1073	+* DIGIT1 STB 1,X store the flag
	1074	+* JMP NEXT
	1075	+* DIGIT2 CLRB ;
	1076	+* LEAS 1,S ;
	1077	+* LEAS 1,S ; pop bottom number
	1078	+* TFR S,X ; TSX :
	1079	+* STB 0,X make sure both bytes are 00
	1080	+* BRA DIGIT1
	1081	+*
	1082	+* ######>> screen 19 <<
	1083	+*
	1084	+* The word definition format in the dictionary:
	1085	+*
	1086	+* (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
	1087	+*
	1088	+* NFA (name field address):
	1089	+* char-count + $80 Length of symbol name, flagged with high bit set.
	1090	+* char 1 Characters of symbol name.
	1091	+* char 2
	1092	+* ...
	1093	+* char n + $80 symbol termination flag (char set < 128 code points)
	1094	+* LFA (link field address):
	1095	+* link high byte \___pointer to previous word in list
	1096	+* link low byte / -- Combined allocation/dictionary list. --
	1097	+* CFA (code field address):
	1098	+* CFA high byte \___pointer to native CPU machine code
	1099	+* CFA low byte / -- Consider this the characteristic code. --
	1100	+* PFA (parameter field address):
	1101	+* parameter fields -- Machine code for low-level native machine CPU code,
	1102	+* " instruction list for high-level Forth code,
	1103	+* " constant data for constants, pointers to per task variables,
	1104	+* " space for variables, for global variables, etc.
	1105	+*
	1106	+* In the case of native CPU machine code, the address at CFA will be PFA.
	1107	+
	1108	+* Definition attributes:
	1109	+FIMMED EQU $40 ; Immediate word flag.
	1110	+FSMUDG EQU $20 ; Smudged => definition not ready.
	1111	+CTMASK EQU ($FF&(^($80\|FIMMED))) ; For unmasking the length byte.
	1112	+* Note that the SMUDGE bit is not masked out.
	1113	+*
	1114	+* But we really want more (Thinking for a new model, need one more byte):
	1115	+* FCOMPI EQU $10 ; Compile-time-only.
	1116	+* FASSEM EQU $08 ; Assembly-language code only.
	1117	+* F4THLV EQU $04 ; Must not be called from assembly language code.
	1118	+* These would require some significant adjustments to the model.
	1119	+* We also want to put the low-level VM stuff in its own vocabulary.
	1120	+*
	1121	+* ======>> 11 <<
	1122	+* (FIND) ( name vocptr --- locptr length true )
	1123	+* ( name vocptr --- false )
	1124	+* Search vocabulary for a symbol called name.
	1125	+* name is a pointer to a high-bit bracket string with length head.
	1126	+* vocptr is a pointer to the NFA of the tail-end (LATEST) definition
	1127	+* in the vocabulary to be searched.
	1128	+* Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
	1129	+ FCB $86
	1130	+ FCC '(FIND' ; '(FIND)'
	1131	+ FCB $A9
	1132	+ FDB DIGIT-8
	1133	+PFIND FDB *+NATWID
	1134	+ PSHS Y ; Have to track two pointers.
	1135	+* Use the stack and registers instead of temp area N.
	1136	+PA0 EQU NATWID ; pointer to the length byte of name being searched against
	1137	+PD EQU 0 ; pointer to NFA of dict word being checked
	1138	+*
	1139	+* INC <TRACEM
	1140	+* LBSR DBGREG
	1141	+ LDX PD,U ; Start in on the vocabulary (NFA).
	1142	+PFNDLP LDY PA0,U ; Point to the name to check against.
	1143	+ LDB ,X+ ; get dict name length byte
	1144	+ TFR B,A ; Save it in case it matches.
	1145	+ ANDB #CTMASK
	1146	+* LBSR DBGREG
	1147	+ CMPB ,Y+ ; Compare lengths
	1148	+* LBSR DBGREG
	1149	+ BNE PFNDUN
	1150	+PFNDBR LDB ,X+
	1151	+ TSTB ; ; Is high bit of character in dictionary entry set?
	1152	+* LBSR DBGREG
	1153	+ BPL PFNDCH
	1154	+* LBSR DBGREG
	1155	+ ANDB #$7F ; Clear high bit from dictionary.
	1156	+ CMPB ,Y+ ; Compare "last" characters.
	1157	+* LBSR DBGREG
	1158	+ BEQ FOUND ; Matches even if dictionary actual length is shorter.
	1159	+PFNDLN LDX ,X++ ; Get previous link in vocabulary.
	1160	+* LBSR DBGREG
	1161	+ BNE PFNDLP ; Continue if link not=0
	1162	+*
	1163	+* not found :
	1164	+ LEAU NATWID,U ; Return only false flag.
	1165	+ LDD #0
	1166	+ STD ,U
	1167	+* LBSR DBGREG
	1168	+* DEC <TRACEM
	1169	+ PULS Y
	1170	+ LBRA NEXT
	1171	+*
	1172	+PFNDCH CMPB ,Y+ ; Compare characters.
	1173	+* LBSR DBGREG
	1174	+ BEQ PFNDBR
	1175	+PFNDUN
	1176	+PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
	1177	+* LBSR DBGREG
	1178	+ BPL PFNDSC
	1179	+* LBSR DBGREG
	1180	+ BRA PFNDLN
	1181	+*
	1182	+* found :
	1183	+*
	1184	+FOUND LEAX 2*NATWID,X
	1185	+* LBSR DBGREG
	1186	+ STX NATWID,U
	1187	+ TFR A,B
	1188	+ CLRA
	1189	+ STD ,U
	1190	+* LBSR DBGREG
	1191	+ LDB #1
	1192	+ PSHU A,B
	1193	+* LBSR DBGREG
	1194	+* DEC <TRACEM
	1195	+ PULS Y
	1196	+ LBRA NEXT
	1197	+*
	1198	+* 6800 model:
	1199	+* NOP ; Probably leftovers from a debugging session.
	1200	+* NOP
	1201	+* PD EQU N ptr to dict word being checked
	1202	+* PA0 EQU N+2
	1203	+* PA EQU N+4
	1204	+* PC EQU N+6
	1205	+* LDX #PD
	1206	+* LDB #4
	1207	+* PFIND0 PULS A ; loop to get arguments
	1208	+* STA 0,X
	1209	+* LEAX 1,X ;
	1210	+* DECB ;
	1211	+* BNE PFIND0
	1212	+*
	1213	+* LDX PD
	1214	+* PFNDLP LDB 0,X get count dict count
	1215	+* STB PC
	1216	+* ANDB #$3F
	1217	+* LEAX 1,X ;
	1218	+* STX PD update PD
	1219	+* LDX PA0
	1220	+* LDA 0,X get count from arg
	1221	+* LEAX 1,X ;
	1222	+* STX PA intialize PA
	1223	+* PSHS B ; ** emulating CBA:
	1224	+* CMPA ,S+ ; compare lengths
	1225	+* BNE PFNDUN
	1226	+* PFNDBR LDX PA
	1227	+* LDA 0,X
	1228	+* LEAX 1,X ;
	1229	+* STX PA
	1230	+* LDX PD
	1231	+* LDB 0,X
	1232	+* LEAX 1,X ;
	1233	+* STX PD
	1234	+* TSTB ; is dict entry neg. ?
	1235	+* BPL PFNDCH
	1236	+* ANDB #$7F clear sign
	1237	+* PSHS B ; ** emulating CBA:
	1238	+* CMPA ,S+ ;
	1239	+* BEQ FOUND
	1240	+* PFNDLN LDX 0,X get new link
	1241	+* BNE PFNDLP continue if link not=0
	1242	+*
	1243	+* not found :
	1244	+*
	1245	+* CLRA ;
	1246	+* CLRB ;
	1247	+* JMP PUSHBA
	1248	+* PFNDCH PSHS B ; ** emulating CBA:
	1249	+* CMPA ,S+ ;
	1250	+* BEQ PFNDBR
	1251	+* PFNDUN LDX PD
	1252	+* PFNDSC LDB 0,X scan forward to end of this name
	1253	+* LEAX 1,X ;
	1254	+* BPL PFNDSC
	1255	+* BRA PFNDLN
	1256	+*
	1257	+* found :
	1258	+*
	1259	+* FOUND LDA PD compute CFA
	1260	+* LDB PD+1
	1261	+* ADDB #4
	1262	+* ADCA #0
	1263	+* PSHS B ;
	1264	+* PSHS A ;
	1265	+* LDA PC
	1266	+* PSHS A ;
	1267	+* CLRA ;
	1268	+* PSHS A ;
	1269	+* LDB #1
	1270	+* JMP PUSHBA
	1271	+*
	1272	+* PSHS A ; Left over from a stray copy-paste, I guess.
	1273	+* CLRA ;
	1274	+* PSHS A ;
	1275	+* LDB #1
	1276	+* JMP PUSHBA
	1277	+*
	1278	+* ######>> screen 20 <<
	1279	+* ======>> 12 <<
	1280	+* ( buffer ch --- buffer symboloffset delimiteroffset scancount )
	1281	+* ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
	1282	+* ( buffer ch --- buffer nuloffset onepast scancount )
	1283	+* Scan buffer for a symbol delimited by ch or ASCII NUL,
	1284	+* return the length of the buffer region scanned,
	1285	+* the offset to the trailing delimiter,
	1286	+* and the offset of the first character of the symbol.
	1287	+* Leave the buffer on the stack.
	1288	+* Scancount is also offset to first character not yet looked at.
	1289	+* If no symbol in buffer, scancount and symboloffset point to NUL
	1290	+* and delimiteroffset points one beyond for some reason.
	1291	+* On trailing NUL, delimiteroffset == scancount.
	1292	+* (Buffer is the address of the buffer array to scan.)
	1293	+* (This is a bit too tricky, really.)
	1294	+ FCB $87
	1295	+ FCC 'ENCLOS' ; 'ENCLOSE'
	1296	+ FCB $C5
	1297	+ FDB PFIND-9
	1298	+ENCLOS FDB *+NATWID
	1299	+ LDA 1,U ; Delimiter character to match against in A.
	1300	+ LDX NATWID,U ; Buffer to scan in.
	1301	+ CLRB ; Initialize offset. (Buffer < 256 wide!)
	1302	+* Scan to a non-delimiter or a NUL
	1303	+ENCDEL TST B,X ; NUL ?
	1304	+ BEQ ENCNUL
	1305	+ CMPA B,X ; Delimiter?
	1306	+ BNE ENC1ST
	1307	+ INCB ; count character
	1308	+ BRA ENCDEL
	1309	+* Found first character. Save the offset.
	1310	+ENC1ST STB 1,U ; Found first non-delimiter character --
	1311	+ CLR ,U ; store the count, zero high byte.
	1312	+* Scan to a delimiter or a NUL
	1313	+ENCSYM TST B,X ; NUL ?
	1314	+ BEQ ENC0TR
	1315	+ CMPA B,X ; delimiter?
	1316	+ BEQ ENCEND
	1317	+ INCB
	1318	+ BRA ENCSYM
	1319	+* Found end of symbol. Push offset to delimiter found.
	1320	+ENCEND CLRA ; high byte -- buffer < 255 wide!
	1321	+ PSHU A,B ; Offset to seen delimiter.
	1322	+* Advance and push address of next character to check.
	1323	+ ADDD #1 ; In case offset was 255.
	1324	+ PSHU A,B
	1325	+ LBRA NEXT
	1326	+* Found NUL before non-delimiter, therefore there is no word
	1327	+ENCNUL CLRA ; high byte -- buffer < 255 wide!
	1328	+ STD ,U ; offset to NUL.
	1329	+ ADDD #1 ; Point after NUL to allow (FIND) to match it.
	1330	+ PSHU A,B ;
	1331	+ SUBD #1 ; Next is not passed NUL.
	1332	+ PSHU A,B ; Stealing code will save only one byte.
	1333	+ LBRA NEXT
	1334	+* Found NUL following the word instead of delimiter.
	1335	+ENC0TR
	1336	+* INC <TRACEM
	1337	+* LBSR DBGREG
	1338	+ CLRA
	1339	+ PSHU A,B ; Save offset to first after symbol (NUL)
	1340	+* LBSR DBGREG
	1341	+ PSHU A,B ; and count scanned.
	1342	+* LBSR DBGREG
	1343	+* DEC <TRACEM
	1344	+ LBRA NEXT
	1345	+* NOTE :
	1346	+* FC means offset (bytes) to First Character of next word
	1347	+* EW " " to End of Word
	1348	+* NC " " to Next Character to start next enclose at
	1349	+* ENCLOS FDB *+NATWID
	1350	+* LEAS 1,S ;
	1351	+* PULS B ; now, get the low byte, for an 8-bit delimiter
	1352	+* TFR S,X ; TSX :
	1353	+* LDX 0,X
	1354	+* CLR N
	1355	+* * wait for a non-delimiter or a NUL
	1356	+* ENCDEL LDA 0,X
	1357	+* BEQ ENCNUL
	1358	+* PSHS B ; ** emulating CBA:
	1359	+* CMPA ,S+ ; CHECK FOR DELIM
	1360	+* BNE ENC1ST
	1361	+* LEAX 1,X ;
	1362	+* INC N
	1363	+* BRA ENCDEL
	1364	+* * found first character. Push FC
	1365	+* ENC1ST LDA N found first char.
	1366	+* PSHS A ;
	1367	+* CLRA ;
	1368	+* PSHS A ;
	1369	+* wait for a delimiter or a NUL
	1370	+* ENCSYM LDA 0,X
	1371	+* BEQ ENC0TR
	1372	+* PSHS B ; ** emulating CBA:
	1373	+* CMPA ,S+ ; ckech for delim.
	1374	+* BEQ ENCEND
	1375	+* LEAX 1,X ;
	1376	+* INC N
	1377	+* BRA ENCSYM
	1378	+* * found EW. Push it
	1379	+* ENCEND LDB N
	1380	+* CLRA ;
	1381	+* PSHS B ;
	1382	+* PSHS A ;
	1383	+* * advance and push NC
	1384	+* INCB ;
	1385	+* JMP PUSHBA
	1386	+* found NUL before non-delimiter, therefore there is no word
	1387	+* ENCNUL LDB N found NUL
	1388	+* PSHS B ;
	1389	+* PSHS A ;
	1390	+* INCB ;
	1391	+* BRA ENC0TR+2 ; ******** POTENTIAL BUG HERE *****
	1392	+* ****** Should use labels in case opcodes change! ******
	1393	+* found NUL following the word instead of SPACE
	1394	+* ENC0TR LDB N
	1395	+* PSHS B ; save EW
	1396	+* PSHS A ;
	1397	+* ENCL8 LDB N save NC
	1398	+* JMP PUSHBA
	1399	+
	1400	+ PAGE
	1401	+*
	1402	+* ######>> screen 21 <<
	1403	+* The next 4 words call system dependant I/O routines
	1404	+* which are listed after word "-->" ( lable: "arrow" )
	1405	+* in the dictionary.
	1406	+*
	1407	+* ======>> 13 <<
	1408	+* ( c --- )
	1409	+* Write c to the output device (screen or printer).
	1410	+* ROM Uses the ECB device number at address $6F,
	1411	+* -2 is printer, 0 is screen.
	1412	+ FCB $84
	1413	+ FCC 'EMI' ; 'EMIT'
	1414	+ FCB $D4
	1415	+ FDB ENCLOS-10
	1416	+EMIT FDB *+NATWID
	1417	+ PULU D
	1418	+ LBSR PEMIT ; PEMIT expects the character in D.
	1419	+ INC <XOUT+1
	1420	+ BNE EMITDN
	1421	+ INC <XOUT
	1422	+EMITDN LBRA NEXT
	1423	+* PULS A ;
	1424	+* PULS A ;
	1425	+* JSR PEMIT
	1426	+* LDX UP
	1427	+* INC XOUT+1-UORIG,X
	1428	+* BNE *+4 ;
	1429	+* **WARNING** HARD OFFSET: +4 ***
	1430	+* INC XOUT-UORIG,X
	1431	+* JMP NEXT
	1432	+*
	1433	+* ======>> 14 <<
	1434	+* ( --- c )
	1435	+* ( --- BREAK )
	1436	+* Wait for a key from the keyboard.
	1437	+* If the key is BREAK, set the high byte (result $FF03).
	1438	+ FCB $83
	1439	+ FCC 'KE' ; 'KEY'
	1440	+ FCB $D9
	1441	+ FDB EMIT-7
	1442	+KEY FDB *+NATWID
	1443	+ LBSR PKEY ; PKEY leaves the key/break code in D.
	1444	+ PSHU D
	1445	+ LBRA NEXT
	1446	+* JSR PKEY
	1447	+* PSHS A ;
	1448	+* CLRA ;
	1449	+* PSHS A ;
	1450	+* JMP NEXT
	1451	+*
	1452	+* ======>> 15 <<
	1453	+* ( --- f )
	1454	+* Scan keyboard, but do not wait.
	1455	+* Return 0 if no key,
	1456	+* BREAK ($ff03) if BREAK is pressed,
	1457	+* or key currently pressed.
	1458	+ FCB $89
	1459	+ FCC '?TERMINA' ; '?TERMINAL'
	1460	+ FCB $CC
	1461	+ FDB KEY-6
	1462	+QTERM FDB *+NATWID
	1463	+ LBSR PQTER ; PQTER leaves the flag/key in D.
	1464	+ PSHU D
	1465	+ LBRA NEXT
	1466	+* JSR PQTER
	1467	+* CLRB ;
	1468	+* JMP PUSHBA stack the flag
	1469	+*
	1470	+* ======>> 16 <<
	1471	+* ( --- )
	1472	+* EMIT a Carriage Return (ASCII CR).
	1473	+ FCB $82
	1474	+ FCC 'C' ; 'CR'
	1475	+ FCB $D2
	1476	+ FDB QTERM-12
	1477	+CR FDB *+NATWID
	1478	+* LBSR DBGREG
	1479	+ LBSR PCR ; Nothing really to do here.
	1480	+ LBRA NEXT
	1481	+* JSR PCR
	1482	+* JMP NEXT
	1483	+*
	1484	+* ######>> screen 22 <<
	1485	+* ======>> 17 <<
	1486	+* ( source target count --- )
	1487	+* Copy/move count bytes from source to target.
	1488	+* Moves ascending addresses,
	1489	+* so that overlapping only works if the source is above the destination.
	1490	+ FCB $85
	1491	+ FCC 'CMOV' ; 'CMOVE' : source, destination, count
	1492	+ FCB $C5
	1493	+ FDB CR-5
	1494	+CMOVE FDB *+NATWID
	1495	+* Another way ; takes ( 42+17count+9(count/256) cycles )
	1496	+ LDD #0 ; #3~3
	1497	+ SUBD ,U++ ; #2~9 ; invert the count
	1498	+ PSHS A,Y ; #2~8
	1499	+ PULU X,Y ; #2~9
	1500	+ BEQ CMOVEX ; #2~3
	1501	+CMOVEL
	1502	+ LDA ,Y+ ; #2~6
	1503	+ STA ,X+ ; #2~6
	1504	+ INCB ; #1~2
	1505	+ BNE CMOVEL ; #2~3
	1506	+ INC ,S ; #2~6
	1507	+ BNE CMOVEL ; #2~3
	1508	+CMOVEX PULS A,Y ; #2~8
	1509	+ LBRA NEXT ; #3~5
	1510	+* PSHS Y ;
	1511	+* INC <TRACEM
	1512	+* LBSR DBGREG
	1513	+* LDX 1*NATWID,U
	1514	+* LDY 2*NATWID,U
	1515	+* BRA CMOVLE ;
	1516	+* CMOVLP
	1517	+* LBSR DBGREG
	1518	+* LDA ,Y+
	1519	+* STA ,X+
	1520	+* LBSR DBGREG
	1521	+* CMOVLE
	1522	+* LDD ,U
	1523	+* SUBD #1
	1524	+* STD ,U
	1525	+* BCC CMOVLP
	1526	+* LEAU 3*NATWID,U
	1527	+* DEC <TRACEM
	1528	+* PULS Y
	1529	+* LBRA NEXT
	1530	+* One way: ; takes ( 37+17count+9(count/256) cycles )
	1531	+* PSHS Y ; #2~7 ; Gotta have our pointers.
	1532	+* INC <TRACEM
	1533	+* LBSR DBGREG
	1534	+* PULU D,X,Y ; #2~11
	1535	+* PSHS A ; #2~6 ; Gotta have our pointers.
	1536	+* BRA CMOVLE ; #2~3
	1537	+* CMOVLP
	1538	+* LBSR DBGREG
	1539	+* LDA ,Y+ ; #2~6
	1540	+* STA ,X+ ; #2~6
	1541	+* LBSR DBGREG
	1542	+* CMOVLE
	1543	+* SUBB #1 ; #2~2
	1544	+* BCC CMOVLP ; #2~3
	1545	+* DEC ,S ; #2=6
	1546	+* BPL CMOVLP ; #2~3 ; If this actually works, it is limited to 32k here.
	1547	+* DEC <TRACEM
	1548	+* PULS A,Y
	1549	+* LBRA NEXT ; #3~5
	1550	+* Yet another way ; takes ( 37+29*count cycles )
	1551	+* PSHS Y ; #2~7
	1552	+* LDX NATWID,U ; #2~6
	1553	+* LDY NATWID,U ; #3~7
	1554	+* BRA CMOVLE ; #2~3
	1555	+* CMOVLP
	1556	+* LDA ,Y+ ; #2~6
	1557	+* STA ,X+ ; #2~6
	1558	+* CMOVLE
	1559	+* LDD ,U ; #2~5
	1560	+* SUBD #1 ; #3~4
	1561	+* STD ,U ; #2~5
	1562	+* BPL CMOVLP ; #2~3
	1563	+* LEAU 3*NATWID,U ; #2~5
	1564	+* PULS Y
	1565	+* LBRA NEXT ; #3~5
	1566	+* Yet another way ; takes ( 44+24odd+33count/2 cycles )
	1567	+* PSHS Y ; #2~7
	1568	+* LDX NATWID,U ; #2~6
	1569	+* LDY 2*NATWID,U ; #3~7
	1570	+* LDD ,U ; #2~5
	1571	+* BITB #1 ; #2~2
	1572	+* BEQ CMOVLE ; #2~3
	1573	+* SUBD #1 ; #3~4
	1574	+* STD ,U ; #2~5
	1575	+* LDA ,Y+ ; #2~6
	1576	+* STA ,X+ ; #2~6
	1577	+* BRA CMOVLE ; #2~3
	1578	+* CMOVLP
	1579	+* LDD ,Y++ ; #2~8
	1580	+* STD ,X++ ; #2~8
	1581	+* CMOVLI
	1582	+* LDD ,U ; #2~5
	1583	+* CMOVLE
	1584	+* SUBD #2 ; #3~4
	1585	+* STD ,U ; #2~5
	1586	+* BPL CMOVLP ; #2~3
	1587	+* LEAU 3*NATWID,U ; #2~5
	1588	+* PULS Y
	1589	+* LBRA NEXT ; #3~5
	1590	+* From the 6800 model:
	1591	+* CMOVE FDB +2 takes ( 43+47count cycles ) on 6800
	1592	+* LDX #N
	1593	+* LDB #6
	1594	+* CMOV1 PULS A ;
	1595	+* STA 0,X move parameters to scratch area
	1596	+* LEAX 1,X ;
	1597	+* DECB ;
	1598	+* BNE CMOV1
	1599	+* CMOV2 LDA N
	1600	+* LDB N+1
	1601	+* SUBB #1
	1602	+* SBCA #0
	1603	+* STA N
	1604	+* STB N+1
	1605	+* BCS CMOV3
	1606	+* LDX N+4
	1607	+* LDA 0,X
	1608	+* LEAX 1,X ;
	1609	+* STX N+4
	1610	+* LDX N+2
	1611	+* STA 0,X
	1612	+* LEAX 1,X ;
	1613	+* STX N+2
	1614	+* BRA CMOV2
	1615	+* CMOV3 JMP NEXT
	1616	+*
	1617	+* ######>> screen 23 <<
	1618	+* ======>> 18 <<
	1619	+* ( u1 u2 --- ud )
	1620	+* Multiplies the top two unsigned integers,
	1621	+* yielding a double integer product.
	1622	+* Significantly faster than a bit method.
	1623	+ FCB $82
	1624	+ FCC 'U' ; 'U*'
	1625	+ FCB $AA
	1626	+ FDB CMOVE-8
	1627	+USTAR FDB *+NATWID
	1628	+ LEAU -2*NATWID,U
	1629	+ LDA 2*NATWID+1,U ; least
	1630	+ LDB 3*NATWID+1,U
	1631	+ MUL
	1632	+ STD NATWID,U
	1633	+ LDA 2*NATWID,U ; most
	1634	+ LDB 3*NATWID,U
	1635	+ MUL
	1636	+ STD ,U
	1637	+ LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi)
	1638	+ MUL
	1639	+ ADDD 1,U
	1640	+ BCC USTAR3
	1641	+ INC ,U
	1642	+USTAR3 STD 1,U
	1643	+ LDA 2*NATWID,U ; second inner (u2 hi)
	1644	+ LDB 3*NATWID,U ; (u1 lo)
	1645	+ MUL
	1646	+ ADDD 1,U
	1647	+ BCC USTAR4
	1648	+ INC ,U
	1649	+USTAR4 STD 1,U
	1650	+ PULU D,X
	1651	+ STD ,U
	1652	+ STX NATWID,U
	1653	+ LBRA NEXT
	1654	+*
	1655	+* from 6800 model:
	1656	+* BSR USTARS
	1657	+* LEAS 1,S ;
	1658	+* LEAS 1,S ;
	1659	+* JMP PUSHBA
	1660	+*
	1661	+* The following is a subroutine which
	1662	+* multiplies top 2 words on stack,
	1663	+* leaving 32-bit result: high order word in A,B
	1664	+* low order word in 2nd word of stack.
	1665	+*
	1666	+* 6809 version
	1667	+* USTARS LDA #16 bits/word counter
	1668	+* PSHS A ;
	1669	+* LDD #0 ;
	1670	+* USTAR2 ROR 2,U shift multiplier
	1671	+* ROR 3,U
	1672	+* DEC 0,X done?
	1673	+* BMI USTAR4
	1674	+* BCC USTAR3
	1675	+* ADDD 2,X
	1676	+* USTAR3 RORA ;
	1677	+* RORB ; shift result
	1678	+* BRA USTAR2
	1679	+* USTAR4 LEAS 1,S ; dump counter
	1680	+* RTS
	1681	+*
	1682	+* From the 6800 model:
	1683	+* USTARS LDA #16 bits/word counter
	1684	+* PSHS A ;
	1685	+* CLRA ;
	1686	+* CLRB ;
	1687	+* TFR S,X ; TSX :
	1688	+* USTAR2 ROR 5,X shift multiplier
	1689	+* ROR 6,X
	1690	+* DEC 0,X done?
	1691	+* BMI USTAR4
	1692	+* BCC USTAR3
	1693	+* ADDB 4,X
	1694	+* ADCA 3,X
	1695	+* USTAR3 RORA ;
	1696	+* RORB ; shift result
	1697	+* BRA USTAR2
	1698	+* USTAR4 LEAS 1,S ; dump counter
	1699	+* RTS
	1700	+*
	1701	+* ######>> screen 24 <<
	1702	+* ======>> 19 <<
	1703	+* ( ud u --- uremainder uquotient )
	1704	+* Divides the top unsigned integer
	1705	+* into the second and third words on the stack
	1706	+* as a single unsigned double integer,
	1707	+* leaving the remainder and quotient (quotient on top)
	1708	+* as unsigned integers.
	1709	+*
	1710	+* The smaller the divisor, the more likely dropping the high word
	1711	+* of the quotient loses significant bits. See M/MOD .
	1712	+*
	1713	+ FCB $82
	1714	+ FCC 'U' ; 'U/'
	1715	+ FCB $AF
	1716	+ FDB USTAR-5
	1717	+USLASH FDB *+NATWID
	1718	+ LDA #17 ; bit ct
	1719	+ PSHS A
	1720	+ LDD NATWID,U ; dividend
	1721	+USLDIV CMPD ,U ; divisor
	1722	+ BHS USLSUB
	1723	+ ANDCC #~1 ; carry clear
	1724	+ BRA USLBIT
	1725	+USLSUB SUBD ,U
	1726	+ ORCC #1 ; quotient, (carry set)
	1727	+USLBIT ROL 2*NATWID+1,U ; save it
	1728	+ ROL 2*NATWID,U
	1729	+ DEC ,S ; more bits?
	1730	+ BEQ USLR
	1731	+ ROLB ; remainder
	1732	+ ROLA
	1733	+ BCC USLDIV
	1734	+ BRA USLSUB
	1735	+USLR LEAU NATWID,U
	1736	+ LDX NATWID,U
	1737	+ STD NATWID,U
	1738	+ STX ,U
	1739	+ LEAS 1,S
	1740	+ LBRA NEXT
	1741	+*
	1742	+* from 6800 model:
	1743	+* LDA #17
	1744	+* PSHS A ;
	1745	+* TFR S,X ; TSX :
	1746	+* LDA 3,X
	1747	+* LDB 4,X
	1748	+* USL1 CMPA 1,X
	1749	+* BHI USL3
	1750	+* BCS USL2
	1751	+* CMPB 2,X
	1752	+* BCC USL3
	1753	+* USL2 ANDCC #~$01 ; CLC :
	1754	+* BRA USL4
	1755	+* USL3 SUBB 2,X
	1756	+* SBCA 1,X
	1757	+* ORCC #$01 ; SEC :
	1758	+* USL4 ROL 6,X
	1759	+* ROL 5,X
	1760	+* DEC 0,X
	1761	+* BEQ USL5
	1762	+* ROLB ;
	1763	+* ROLA ;
	1764	+* BCC USL1
	1765	+* BRA USL3
	1766	+* USL5 LEAS 1,S ;
	1767	+* LEAS 1,S ;
	1768	+* LEAS 1,S ;
	1769	+* LEAS 1,S ;
	1770	+* LEAS 1,S ;
	1771	+* JMP SWAP+4 reverse quotient & remainder
	1772	+*
	1773	+* ######>> screen 25 <<
	1774	+* ======>> 20 <<
	1775	+* ( n1 n2 --- n )
	1776	+* Bitwise and the top two integers.
	1777	+ FCB $83
	1778	+ FCC 'AN' ; 'AND'
	1779	+ FCB $C4
	1780	+ FDB USLASH-5
	1781	+AND FDB *+NATWID
	1782	+ PULU A,B
	1783	+ ANDB 1,U
	1784	+ ANDA ,U
	1785	+ STD ,U
	1786	+ LBRA NEXT
	1787	+* PULS A ;
	1788	+* PULS B ;
	1789	+* TFR S,X ; TSX :
	1790	+* ANDB 1,X
	1791	+* ANDA 0,X
	1792	+* JMP STABX
	1793	+*
	1794	+* ======>> 21 <<
	1795	+* ( n1 n2 --- n )
	1796	+* Bitwise or the top two integers.
	1797	+ FCB $82
	1798	+ FCC 'O' ; 'OR'
	1799	+ FCB $D2
	1800	+ FDB AND-6
	1801	+OR FDB *+NATWID
	1802	+ PULU A,B
	1803	+ ORB 1,U
	1804	+ ORA ,U
	1805	+ STD ,U
	1806	+ LBRA NEXT
	1807	+* PULS A ;
	1808	+* PULS B ;
	1809	+* TFR S,X ; TSX :
	1810	+* ORB 1,X
	1811	+* ORA 0,X
	1812	+* JMP STABX
	1813	+*
	1814	+* ======>> 22 <<
	1815	+* ( n1 n2 --- n )
	1816	+* Bitwise exclusive or the top two integers.
	1817	+ FCB $83
	1818	+ FCC 'XO' ; 'XOR'
	1819	+ FCB $D2
	1820	+ FDB OR-5
	1821	+XOR FDB *+NATWID
	1822	+ PULU A,B
	1823	+ EORB 1,U
	1824	+ EORA ,U
	1825	+ STD ,U
	1826	+ LBRA NEXT
	1827	+* PULS A ;
	1828	+* PULS B ;
	1829	+* TFR S,X ; TSX :
	1830	+* EORB 1,X
	1831	+* EORA 0,X
	1832	+* JMP STABX
	1833	+*
	1834	+* ######>> screen 26 <<
	1835	+* ======>> 23 <<
	1836	+* ( --- adr )
	1837	+* Fetch the parameter stack pointer (before it is pushed).
	1838	+* This points at whatever was on the top of stack before.
	1839	+ FCB $83
	1840	+ FCC 'SP' ; 'SP@'
	1841	+ FCB $C0
	1842	+ FDB XOR-6
	1843	+SPAT FDB *+NATWID
	1844	+ TFR U,X
	1845	+ PSHU X
	1846	+ LBRA NEXT
	1847	+* TFR S,X ; TSX :
	1848	+* STX N scratch area
	1849	+* LDX #N
	1850	+* JMP GETX
	1851	+*
	1852	+* ======>> 24 <<
	1853	+* ( whatever --- nothing )
	1854	+* Initialize the parameter stack pointer from the USER variable S0.
	1855	+* Effectively clears the stack.
	1856	+ FCB $83
	1857	+ FCC 'SP' ; 'SP!'
	1858	+ FCB $A1
	1859	+ FDB SPAT-6
	1860	+SPSTOR FDB *+NATWID
	1861	+ LDU <XSPZER
	1862	+ LBRA NEXT
	1863	+* LDX UP
	1864	+* LDX XSPZER-UORIG,X
	1865	+* TFR X,S ; TXS : watch it ! X and S are not equal on 6800.
	1866	+* JMP NEXT
	1867	+* ======>> 25 <<
	1868	+* ( whatever *** nothing )
	1869	+* Initialize the return stack pointer from the initialization table
	1870	+* instead of the user variable R0, for some reason.
	1871	+* Quite possibly, this should be from R0.
	1872	+* Effectively aborts all in process definitions, except the active one.
	1873	+* An emergency measure, to be sure.
	1874	+* The routine that calls this must never execute a return.
	1875	+* So this should never be executed from the terminal, I guess.
	1876	+* This is another that should be compile-time only, and in a separate vocabulary.
	1877	+ FCB $83
	1878	+ FCC 'RP' ; 'RP!'
	1879	+ FCB $A1
	1880	+ FDB SPSTOR-6
	1881	+RPSTOR FDB *+NATWID
	1882	+ LDS RINIT,PCR
	1883	+* LBSR DBGREG
	1884	+ LBRA NEXT
	1885	+* LDX RINIT initialize from rom constant
	1886	+* STX RP
	1887	+* JMP NEXT
	1888	+*
	1889	+* ======>> 26 <<
	1890	+* ( ip *** )
	1891	+* Pop IP from return stack (return from high-level definition).
	1892	+* Can be used in a screen to force interpretion to terminate.
	1893	+* Must not be executed when temporaries are saved on top of the return stack.
	1894	+ FCB $82
	1895	+ FCC ';' ; ';S'
	1896	+ FCB $D3
	1897	+ FDB RPSTOR-6
	1898	+SEMIS FDB *+NATWID
	1899	+* LBSR DBGREG
	1900	+ PULS Y ; saved IP in Y.
	1901	+ LBRA NEXT
	1902	+*
	1903	+* Form 6800 model:
	1904	+* LDX RP
	1905	+* LEAX 1,X ;
	1906	+* LEAX 1,X ;
	1907	+* STX RP
	1908	+* LDX 0,X get address we have just finished.
	1909	+* JMP NEXT+2 increment the return address & do next word
	1910	+*
	1911	+* ######>> screen 27 <<
	1912	+* ======>> 27 <<
	1913	+* ( limit index *** index index )
	1914	+* Force the terminating condition for the innermost loop by
	1915	+* copying its index to its limit.
	1916	+* Termination is postponed until the next
	1917	+* LOOP or +LOOP instruction is executed.
	1918	+* The index remains available for use until
	1919	+* the LOOP or +LOOP instruction is encountered.
	1920	+* Note that the assumption is that the current count is the correct count
	1921	+* to end at, rather than pushing the count to the final count.
	1922	+ FCB $85
	1923	+ FCC 'LEAV' ; 'LEAVE'
	1924	+ FCB $C5
	1925	+ FDB SEMIS-5
	1926	+LEAVE FDB *+NATWID
	1927	+ LDD ,S ; No return address to dodge.
	1928	+ STD NATWID,S
	1929	+ LBRA NEXT
	1930	+* LDX RP
	1931	+* LDA 2,X
	1932	+* LDB 3,X
	1933	+* STA 4,X
	1934	+* STB 5,X
	1935	+* JMP NEXT
	1936	+*
	1937	+* ======>> 28 <<
	1938	+* ( n --- )
	1939	+* ( *** n )
	1940	+* Move top of parameter stack to top of return stack.
	1941	+ FCB $82
	1942	+ FCC '>' ; '>R'
	1943	+ FCB $D2
	1944	+ FDB LEAVE-8
	1945	+TOR FDB *+NATWID
	1946	+ PULU D
	1947	+ PSHS D
	1948	+ LBRA NEXT
	1949	+* LDX RP
	1950	+* LEAX -1,X ;
	1951	+* LEAX -1,X ;
	1952	+* STX RP
	1953	+* PULS A ;
	1954	+* PULS B ;
	1955	+* STA 2,X
	1956	+* STB 3,X
	1957	+* JMP NEXT
	1958	+*
	1959	+* ======>> 29 <<
	1960	+* ( --- n )
	1961	+* ( n *** )
	1962	+* Move top of return stack to top of parameter stack.
	1963	+ FCB $82
	1964	+ FCC 'R' ; 'R>'
	1965	+ FCB $BE
	1966	+ FDB TOR-5
	1967	+FROMR FDB *+NATWID
	1968	+ PULS D
	1969	+ PSHU D
	1970	+ LBRA NEXT
	1971	+* LDX RP
	1972	+* LDA 2,X
	1973	+* LDB 3,X
	1974	+* LEAX 1,X ;
	1975	+* LEAX 1,X ;
	1976	+* STX RP
	1977	+* JMP PUSHBA
	1978	+*
	1979	+* ======>> 30 <<
	1980	+* ( --- n )
	1981	+* ( n *** n )
	1982	+* Copy the top of return stack to top of parameter stack.
	1983	+* A synonym for I.
	1984	+ FCB $81 R
	1985	+ FCB $D2
	1986	+ FDB FROMR-5
	1987	+R FDB I+NATWID
	1988	+
	1989	+* LDX RP
	1990	+* LEAX 1,X ;
	1991	+* LEAX 1,X ;
	1992	+* JMP GETX
	1993	+*
	1994	+* ######>> screen 28 <<
	1995	+* ======>> 31 <<
	1996	+* ( n --- ~n )
	1997	+* Logically invert top of stack;
	1998	+* or flag true if top is zero, otherwise false.
	1999	+ FCB $83
	2000	+ FCC 'NO' ; 'NOT'
	2001	+ FCB $D4
	2002	+ FDB R-4
	2003	+LNOT FDB *+NATWID
	2004	+ COM 1,U
	2005	+ COM ,U
	2006	+ LBRA NEXT
	2007	+* ( n --- n=0 )
	2008	+* Logically invert top of stack;
	2009	+* or flag true if top is zero, otherwise false.
	2010	+ FCB $82
	2011	+ FCC '0' ; '0='
	2012	+ FCB $BD
	2013	+ FDB LNOT-6
	2014	+ZEQU FDB *+NATWID
	2015	+ LDD #0
	2016	+ LDX ,U
	2017	+ BNE ZEQUF
	2018	+ INCB ; 1 is true
	2019	+ZEQUF STD ,U
	2020	+ LBRA NEXT
	2021	+* TFR S,X ; TSX :
	2022	+* CLRA ;
	2023	+* CLRB ;
	2024	+* LDX 0,X
	2025	+* BNE ZEQU2
	2026	+* INCB ;
	2027	+*ZEQU2 TFR S,X ; TSX :
	2028	+* JMP STABX
	2029	+*
	2030	+* ======>> 32 <<
	2031	+* ( n --- n<0 )
	2032	+* Flag true if top is negative (MSbit set), otherwise false.
	2033	+ FCB $82
	2034	+ FCC '0' ; '0<'
	2035	+ FCB $BC
	2036	+ FDB ZEQU-5
	2037	+ZLESS FDB *+NATWID
	2038	+ LDD #0
	2039	+ TST ,U
	2040	+ BPL ZLESSF
	2041	+ INCB
	2042	+ZLESSF STD ,U
	2043	+ LBRA NEXT
	2044	+* TFR S,X ; TSX :
	2045	+* LDA #$80 check the sign bit
	2046	+* ANDA 0,X
	2047	+* BEQ ZLESS2
	2048	+* CLRA ; if neg.
	2049	+* LDB #1
	2050	+* JMP STABX
	2051	+* ZLESS2 CLRB ;
	2052	+* JMP STABX
	2053	+*
	2054	+* ######>> screen 29 <<
	2055	+* ======>> 33 <<
	2056	+* ( n1 n2 --- n1+n2 )
	2057	+* Add top two words.
	2058	+ FCB $81 '+'
	2059	+ FCB $AB
	2060	+ FDB ZLESS-5
	2061	+PLUS FDB *+NATWID
	2062	+ PULU A,B ; #2~7
	2063	+ ADDD ,U ; #2~6
	2064	+ STD ,U ; #2~5
	2065	+ LBRA NEXT ; #1~5 =#7~23
	2066	+* PULS A ;
	2067	+* PULS B ;
	2068	+* TFR S,X ; TSX :
	2069	+* ADDB 1,X
	2070	+* ADCA 0,X
	2071	+* JMP STABX
	2072	+*
	2073	+* ======>> 34 <<
	2074	+* ( d1 d2 --- d1+d2 )
	2075	+* Add top two double integers.
	2076	+ FCB $82
	2077	+ FCC 'D' ; 'D+'
	2078	+ FCB $AB
	2079	+ FDB PLUS-4
	2080	+DPLUS FDB *+NATWID
	2081	+ LDD 3*NATWID,U
	2082	+ ADDD NATWID,U
	2083	+ STD 3*NATWID,U
	2084	+ LDD 2*NATWID,U
	2085	+ ADCB 1,U
	2086	+ ADCA ,U
	2087	+ LEAU 2*NATWID,U
	2088	+ STD ,U
	2089	+ LBRA NEXT
	2090	+* TFR S,X ; TSX :
	2091	+* ANDCC #~$01 ; CLC :
	2092	+* LDB #4
	2093	+* DPLUS2 LDA 3,X
	2094	+* ADCA 7,X
	2095	+* STA 7,X
	2096	+* LEAX -1,X ;
	2097	+* DECB ;
	2098	+* BNE DPLUS2
	2099	+* LEAS 1,S ;
	2100	+* LEAS 1,S ;
	2101	+* LEAS 1,S ;
	2102	+* LEAS 1,S ;
	2103	+* JMP NEXT
	2104	+*
	2105	+* ======>> 35 <<
	2106	+* ( n --- -n )
	2107	+* Negate (two's complement) top of stack.
	2108	+ FCB $85
	2109	+ FCC 'MINU' ; 'MINUS'
	2110	+ FCB $D3
	2111	+ FDB DPLUS-5
	2112	+MINUS FDB *+NATWID
	2113	+ LDD #0 ; #3~3
	2114	+ SUBD ,U ; #2~5
	2115	+ STD ,U ; #2~5
	2116	+ LBRA NEXT ; #1~5 = #8~18
	2117	+*
	2118	+* from 6800 model code:
	2119	+* TFR S,X ; TSX :
	2120	+* NEG 1,X
	2121	+* BCC MINUS2
	2122	+* NEG 0,X
	2123	+* BRA MINUS3
	2124	+* MINUS2 COM 0,X
	2125	+* MINUS3 JMP NEXT
	2126	+*
	2127	+* ======>> 36 <<
	2128	+* ( d --- -d )
	2129	+* Negate (two's complement) top two words on stack as a double integer.
	2130	+ FCB $86
	2131	+ FCC 'DMINU' ; 'DMINUS'
	2132	+ FCB $D3
	2133	+ FDB MINUS-8
	2134	+DMINUS FDB *+NATWID
	2135	+ LDD #0 ; #3~3
	2136	+ SUBD NATWID,U ; #2~7
	2137	+ STD NATWID,U ; #2~7
	2138	+ LDD #0 ; #3~3
	2139	+ SBCB 1,U ; #2~5
	2140	+ SBCA ,U ; #2~4
	2141	+ STD ,U ; #2~5
	2142	+ LBRA NEXT ; #1~5 = #17~39
	2143	+* TFR S,X ; TSX :
	2144	+* COM 0,X
	2145	+* COM 1,X
	2146	+* COM 2,X
	2147	+* NEG 3,X
	2148	+* BNE DMINX
	2149	+* INC 2,X
	2150	+* BNE DMINX
	2151	+* INC 1,X
	2152	+* BNE DMINX
	2153	+* INC 0,X
	2154	+* DMINX JMP NEXT
	2155	+*
	2156	+* ######>> screen 30 <<
	2157	+* ======>> 37 <<
	2158	+* ( n1 n2 --- n1 n2 n1 )
	2159	+* Push a copy of the second word on stack.
	2160	+ FCB $84
	2161	+ FCC 'OVE' ; 'OVER'
	2162	+ FCB $D2
	2163	+ FDB DMINUS-9
	2164	+OVER FDB *+NATWID
	2165	+ LDD NATWID,U
	2166	+ PSHU D
	2167	+ LBRA NEXT
	2168	+* TFR S,X ; TSX :
	2169	+* LDA 2,X
	2170	+* LDB 3,X
	2171	+* JMP PUSHBA
	2172	+*
	2173	+* ======>> 38 <<
	2174	+* ( n --- )
	2175	+* Discard the top word on stack.
	2176	+ FCB $84
	2177	+ FCC 'DRO' ; 'DROP'
	2178	+ FCB $D0
	2179	+ FDB OVER-7
	2180	+DROP FDB *+NATWID
	2181	+ LEAU NATWID,U
	2182	+ LBRA NEXT
	2183	+* LEAS 1,S ;
	2184	+* LEAS 1,S ;
	2185	+* JMP NEXT
	2186	+*
	2187	+* ======>> 39 <<
	2188	+* ( n1 n2 --- n2 n1 )
	2189	+* Swap the top two words on stack.
	2190	+ FCB $84
	2191	+ FCC 'SWA' ; 'SWAP'
	2192	+ FCB $D0
	2193	+ FDB DROP-7
	2194	+SWAP FDB *+NATWID
	2195	+ PULU D,X
	2196	+ PSHU D
	2197	+ PSHU X
	2198	+ LBRA NEXT
	2199	+* PULS A ;
	2200	+* PULS B ;
	2201	+* TFR S,X ; TSX :
	2202	+* LDX 0,X
	2203	+* LEAS 1,S ;
	2204	+* LEAS 1,S ;
	2205	+* PSHS B ;
	2206	+* PSHS A ;
	2207	+* STX N
	2208	+* LDX #N
	2209	+* JMP GETX
	2210	+*
	2211	+* ======>> 40 <<
	2212	+* ( n1 --- n1 n1 )
	2213	+* Push a copy of the top word on stack.
	2214	+ FCB $83
	2215	+ FCC 'DU' ; 'DUP'
	2216	+ FCB $D0
	2217	+ FDB SWAP-7
	2218	+DUP FDB *+NATWID
	2219	+ LDD ,U
	2220	+ PSHU D
	2221	+ LBRA NEXT
	2222	+* PULS A ;
	2223	+* PULS B ;
	2224	+* PSHS B ;
	2225	+* PSHS A ;
	2226	+* JMP PUSHBA
	2227	+*
	2228	+* ######>> screen 31 <<
	2229	+* ======>> 41 <<
	2230	+* ( n adr --- )
	2231	+* Add the second word on stack to the word at the adr on top of stack.
	2232	+ FCB $82
	2233	+ FCC '+' ; '+!'
	2234	+ FCB $A1
	2235	+ FDB DUP-6
	2236	+PSTORE FDB *+NATWID
	2237	+ PULU X
	2238	+ LDD ,X
	2239	+ ADDD ,U++
	2240	+ STD ,X
	2241	+ LBRA NEXT
	2242	+* TFR S,X ; TSX :
	2243	+* LDX 0,X
	2244	+* LEAS 1,S ;
	2245	+* LEAS 1,S ;
	2246	+* PULS A ; get stack data
	2247	+* PULS B ;
	2248	+* ADDB 1,X add & store low byte
	2249	+* STB 1,X
	2250	+* ADCA 0,X add & store hi byte
	2251	+* STA 0,X
	2252	+* JMP NEXT
	2253	+*
	2254	+* ======>> 42 <<
	2255	+* ( adr b --- )
	2256	+* Exclusive or byte at adr with low byte of top word.
	2257	+ FCB $86
	2258	+ FCC 'TOGGL' ; 'TOGGLE'
	2259	+ FCB $C5
	2260	+ FDB PSTORE-5
	2261	+TOGGLE FDB *+NATWID
	2262	+ PULU D,X
	2263	+ EORB ,X
	2264	+ STB ,X
	2265	+ LBRA NEXT
	2266	+* Using the model code would be less likely to introduce bugs,
	2267	+* but that would sort-of defeat my purposes here.
	2268	+* Anyway, I can borrow from theoretically known good bif-6809 code
	2269	+* and it's fewer bytes and much faster code this way.
	2270	+* TOGGLE
	2271	+* FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
	2272	+* FDB SEMIS
	2273	+*
	2274	+* ######>> screen 32 <<
	2275	+* ======>> 43 <<
	2276	+* ( adr --- n )
	2277	+* Replace address on stack with the word at the address.
	2278	+ FCB $81 @
	2279	+ FCB $C0
	2280	+ FDB TOGGLE-9
	2281	+AT FDB *+NATWID
	2282	+ LDD [,U]
	2283	+ STD ,U
	2284	+ LBRA NEXT
	2285	+* TFR S,X ; TSX :
	2286	+* LDX 0,X get address
	2287	+* LEAS 1,S ;
	2288	+* LEAS 1,S ;
	2289	+* JMP GETX
	2290	+*
	2291	+* ======>> 44 <<
	2292	+* ( adr --- b )
	2293	+* Replace address on top of stack with the byte at the address.
	2294	+* High byte of result is clear.
	2295	+ FCB $82
	2296	+ FCC 'C' ; 'C@'
	2297	+ FCB $C0
	2298	+ FDB AT-4
	2299	+CAT FDB *+NATWID
	2300	+ LDB [,U]
	2301	+ CLRA
	2302	+ STD ,U
	2303	+ LBRA NEXT
	2304	+
	2305	+
	2306	+* TFR S,X ; TSX :
	2307	+* LDX 0,X
	2308	+* CLRA ;
	2309	+* LDB 0,X
	2310	+* LEAS 1,S ;
	2311	+* LEAS 1,S ;
	2312	+* JMP PUSHBA
	2313	+*
	2314	+* ======>> 45 <<
	2315	+* ( n adr --- )
	2316	+* Store second word on stack at address on top of stack.
	2317	+ FCB $81
	2318	+ FCB $A1
	2319	+ FDB CAT-5
	2320	+STORE FDB *+NATWID
	2321	+ LDD NATWID,U
	2322	+ STD [,U]
	2323	+ LEAU 2*NATWID,U
	2324	+ LBRA NEXT
	2325	+* TFR S,X ; TSX :
	2326	+* LDX 0,X get address
	2327	+* LEAS 1,S ;
	2328	+* LEAS 1,S ;
	2329	+* JMP PULABX
	2330	+*
	2331	+* ======>> 46 <<
	2332	+* ( b adr --- )
	2333	+* Store low byte of second word on stack at address on top of stack.
	2334	+* High byte is ignored.
	2335	+ FCB $82
	2336	+ FCC 'C' ; 'C!'
	2337	+ FCB $A1
	2338	+ FDB STORE-4
	2339	+CSTORE FDB *+NATWID
	2340	+ LDB 3,U
	2341	+ STB [,U]
	2342	+ LEAU 2*NATWID,U
	2343	+ LBRA NEXT
	2344	+* TFR S,X ; TSX :
	2345	+* LDX 0,X get address
	2346	+* LEAS 1,S ;
	2347	+* LEAS 1,S ;
	2348	+* LEAS 1,S ;
	2349	+* PULS B ;
	2350	+* STB 0,X
	2351	+* JMP NEXT
	2352	+ PAGE
	2353	+*
	2354	+* ######>> screen 33 <<
	2355	+* ======>> 47 <<
	2356	+* ( --- ) P
	2357	+* { : name sundry-activities ; } typical input
	2358	+* If executing (not compiling),
	2359	+* record the data stack mark in CSP,
	2360	+* Set the CONTEXT vocabulary to CURRENT,
	2361	+* CREATE a header,
	2362	+* set state to compile,
	2363	+* and compile the call to the trailing native CPU machine code DOCOL.
	2364	+*
	2365	+* This would not be hard to flatten to native code.
	2366	+* But that's not the purpose of a model.
	2367	+ FCB $C1 : immediate
	2368	+ FCB $BA
	2369	+ FDB CSTORE-5
	2370	+COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
	2371	+ FDB CREATE,RBRAK
	2372	+ FDB PSCODE
	2373	+
	2374	+* Here is the IP pusher for allowing
	2375	+* nested words in the virtual machine:
	2376	+* ( ;S is the equivalent un-nester )
	2377	+
	2378	+* ( *** oldIP )
	2379	+* Characteristic of a colon (:) definition.
	2380	+* Begins execution of a high-level definition,
	2381	+* i. e., nests the definition and begins processing icodes.
	2382	+* Mechanically, it pushes the IP (Y register)
	2383	+* and loads the Parameter Field Address of the definition which
	2384	+* called it into the IP.
	2385	+DOCOL PSHS Y ; Nest the old IP.
	2386	+ LEAY NATWID,X ; W still in X, bump to parameters, load as new IP.
	2387	+ LBRA NEXT ; No return, just jump.
	2388	+
	2389	+* DOCOL LDX RP make room in the stack
	2390	+* LEAX -1,X ;
	2391	+* LEAX -1,X ;
	2392	+* STX RP
	2393	+* LDA IP
	2394	+* LDB IP+1
	2395	+* STA 2,X Store address of the high level word
	2396	+* STB 3,X that we are starting to execute
	2397	+* LDX W Get first sub-word of that definition
	2398	+* JMP NEXT+2 and execute it
	2399	+*
	2400	+* ======>> 48 <<
	2401	+* ( --- ) P
	2402	+* { : name sundry-activities ; } typical input
	2403	+* ERROR check data stack against mark in CSP,
	2404	+* compile ;S,
	2405	+* unSMUDGE LATEST definition,
	2406	+* and set state to interpretation.
	2407	+ FCB $C1 ; imnediate code
	2408	+ FCB $BB
	2409	+ FDB COLON-4
	2410	+SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
	2411	+ FDB SEMIS
	2412	+*
	2413	+* ######>> screen 34 <<
	2414	+* ======>> 49 <<
	2415	+* ( n --- )
	2416	+* { value CONSTANT name } typical input
	2417	+* CREATE a header,
	2418	+* unSMUDGE it,
	2419	+* compile the constant value,
	2420	+* and compile the call to the trailing native CPU machine code DOCON.
	2421	+ FCB $88
	2422	+ FCC 'CONSTAN' ; 'CONSTANT'
	2423	+ FCB $D4
	2424	+ FDB SEMI-4
	2425	+CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
	2426	+* ( --- n )
	2427	+* Characteristic of a CONSTANT.
	2428	+* A CONSTANT simply loads its value from its parameter field
	2429	+* and pushes it on the stack.
	2430	+DOCON LDD NATWID,X ; Get the first natural width word of the parameter field.
	2431	+ PSHU D
	2432	+ LBRA NEXT
	2433	+* DOCON LDX W
	2434	+* LDA 2,X
	2435	+* LDB 3,X A & B now contain the constant
	2436	+* JMP PUSHBA
	2437	+*
	2438	+* Not in model, needed for abstraction:
	2439	+* ( --- NATWID )
	2440	+* The byte width of objects on stack.
	2441	+ FCB $86
	2442	+ FCC 'NATWI' ; 'NATWID'
	2443	+ FCB $C4
	2444	+ FDB CON-11
	2445	+NATWC FDB DOCON
	2446	+NATWCV FDB NATWID
	2447	+*
	2448	+* Not in model, needed for abstraction:
	2449	+* Note that this is not defined as an INCREMENTER!
	2450	+* Coded to increment by the exact constant returned by NATWID
	2451	+* ( n --- n+NATWID )
	2452	+ FCB $84
	2453	+ FCC 'NAT' ; 'NAT+'
	2454	+ FCB $AB
	2455	+ FDB NATWC-9
	2456	+NATP FDB *+NATWID
	2457	+ LDD ,U
	2458	+ ADDD NATWCV,PCR ; Looking ahead, does not have to be PCRelative.
	2459	+ STD ,U
	2460	+ LBRA NEXT
	2461	+* How this might have been done for 6800 model:
	2462	+* CLRA ; We know the natural width is less than 255, LOL.
	2463	+* LDAB NATWCV+1
	2464	+* TSX
	2465	+* ADDB 1,X
	2466	+* ADCA ,X
	2467	+* JMP STABX
	2468	+*
	2469	+* ======>> 50 <<
	2470	+* ( init --- )
	2471	+* { init VARIABLE name } typical input
	2472	+* Use CONSTANT to CREATE a header and compile the initial value, init,
	2473	+* then overwrite the characteristic to point to DOVAR.
	2474	+ FCB $88
	2475	+ FCC 'VARIABL' ; 'VARIABLE'
	2476	+ FCB $C5
	2477	+ FDB NATP-7
	2478	+VAR FDB DOCOL,CON,PSCODE
	2479	+* ( --- vadr )
	2480	+* Characteristic of a VARIABLE.
	2481	+* A VARIABLE pushes its PFA address on the stack.
	2482	+* The parameter field of a VARIABLE is the actual allocation of the variable,
	2483	+* so that pushing its address allows its contents to be @ed (fetched).
	2484	+* Ordinary arrays and strings that do not subscript themselves
	2485	+* may be allocated by defining a variable
	2486	+* and immediately ALLOTting the remaining needed space.
	2487	+* VARIABLES are global to all users,
	2488	+* and thus should be hidden in resource monitors, but aren't.
	2489	+DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters.
	2490	+ PSHU X
	2491	+ LBRA NEXT
	2492	+* DOVAR LDA W
	2493	+* LDB W+1
	2494	+* ADDB #2
	2495	+* ADCA #0 A,B now contain the address of the variable
	2496	+* JMP PUSHBA
	2497	+*
	2498	+* ======>> 51 <<
	2499	+* ( ub --- )
	2500	+* { uboffset USER name } typical input
	2501	+* CREATE a header and compile the unsigned byte offset in the per-USER table,
	2502	+* then overwrite the header with a call to DOUSER.
	2503	+* The USER is entirely responsible for maintaining allocation!
	2504	+ FCB $84
	2505	+ FCC 'USE' ; 'USER'
	2506	+ FCB $D2
	2507	+ FDB VAR-11
	2508	+USER FDB DOCOL,CON,PSCODE
	2509	+* ( --- vadr )
	2510	+* Characteristic of a per-USER variable.
	2511	+* USER variables are similiar to VARIABLEs,
	2512	+* but are allocated (by hand!) in the per-user table.
	2513	+* A USER variable's parameter field contains its offset in the per-user table.
	2514	+DOUSER TFR DP,A ; Make a pointer to the direct page.
	2515	+ CLRB
	2516	+* See Alternative -- alternatives start from this point.
	2517	+ ADDD NATWID,X ; Add it to the offset to the per-user variable.
	2518	+ PSHU D
	2519	+ TFR D,X ; Cache the pointer in X for the caller.
	2520	+ LBRA NEXT
	2521	+* Hey, the per-user table could actually be larger than 256 bytes!
	2522	+* But we knew that. It's just not as esthetic to calculate it this way.
	2523	+* Alternative A:
	2524	+* LDX NATWID,X ; Keep the offset
	2525	+* EXG D,X ; Prepare for EA
	2526	+* LEAX D,X
	2527	+* PSHU X
	2528	+* LBRA NEXT
	2529	+* Alternative B:
	2530	+* PSHS Y ; Get Y free for calculations.
	2531	+* TFR D,Y ; Y points to the UP base
	2532	+* LDD NATWID,X ; Get the offset
	2533	+* LEAX D,Y ; Leave the pointer cached in X.
	2534	+* PSHU X
	2535	+* PULS Y,PC
	2536	+*
	2537	+* From the 6800 model:
	2538	+* DOUSER LDX W get offset into user's table
	2539	+* LDA 2,X
	2540	+* LDB 3,X
	2541	+* ADDB UP+1 add to users base address
	2542	+* ADCA UP
	2543	+* JMP PUSHBA push address of user's variable
	2544	+*
	2545	+* ######>> screen 35 <<
	2546	+* ======>> 52 <<
	2547	+* ( --- 0 )
	2548	+ FCB $81
	2549	+ FCB $B0 0
	2550	+ FDB USER-7
	2551	+ZERO FDB DOCON
	2552	+ FDB 0000
	2553	+*
	2554	+* ======>> 53 <<
	2555	+* ( --- 1 )
	2556	+ FCB $81
	2557	+ FCB $B1 1
	2558	+ FDB ZERO-4
	2559	+ONE FDB DOCON
	2560	+ONEV FDB 1
	2561	+*
	2562	+* ======>> 54 <<
	2563	+* ( --- 2 )
	2564	+ FCB $81
	2565	+ FCB $B2 2
	2566	+ FDB ONE-4
	2567	+TWO FDB DOCON
	2568	+TWOV FDB 2
	2569	+*
	2570	+* ======>> 55 <<
	2571	+* ( --- 3 )
	2572	+ FCB $81
	2573	+ FCB $B3 3
	2574	+ FDB TWO-4
	2575	+THREE FDB DOCON
	2576	+ FDB 3
	2577	+*
	2578	+* ======>> 56 <<
	2579	+* ( --- SP )
	2580	+* ASCII SPACE character
	2581	+ FCB $82
	2582	+ FCC 'B' ; 'BL'
	2583	+ FCB $CC
	2584	+ FDB THREE-4
	2585	+BL FDB DOCON ascii blank
	2586	+ FDB $20
	2587	+*
	2588	+* ======>> 57 <<
	2589	+* This really shouldn't be a CONSTANT.
	2590	+* ( --- adr )
	2591	+* The base of the disk buffer space.
	2592	+ FCB $85
	2593	+ FCC 'FIRS' ; 'FIRST'
	2594	+ FCB $D4
	2595	+ FDB BL-5
	2596	+FIRST FDB DOCON
	2597	+ FDB BUFBAS
	2598	+* FDB MEMEND-528 (132 * NBLK)
	2599	+*
	2600	+* ======>> 58 <<
	2601	+* This really shouldn't be a CONSTANT.
	2602	+* ( --- adr )
	2603	+* The limit of the disk buffer space.
	2604	+ FCB $85
	2605	+ FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
	2606	+ FCB $D4
	2607	+ FDB FIRST-8
	2608	+LIMIT FDB DOCON
	2609	+ FDB BUFBAS+BUFSZ
	2610	+* In 6800 model, was
	2611	+* FDB MEMEND
	2612	+*
	2613	+* ======>> 59 <<
	2614	+* ( --- sectorsize )
	2615	+* The size, in bytes, of a buffer control region.
	2616	+ FCB $85
	2617	+ FCC 'B/CT' ; 'B/CTL' : (bytes/control region)
	2618	+ FCB $CC
	2619	+ FDB LIMIT-8
	2620	+BCTL FDB DOCON
	2621	+ FDB SECTRL
	2622	+*
	2623	+* ( --- sectorsize )
	2624	+* The size, in bytes, of a buffer.
	2625	+ FCB $85
	2626	+ FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
	2627	+ FCB $C6
	2628	+ FDB BCTL-8
	2629	+BBUF FDB DOCON
	2630	+ FDB SECTSZ
	2631	+* Hardcoded in 6800 model:
	2632	+* FDB 128
	2633	+*
	2634	+* ======>> 60 <<
	2635	+* ( --- blocksperscreen )
	2636	+* The size, in blocks, of a screen.
	2637	+* Should this be the same as NBLK, the number of block buffers maintained?
	2638	+ FCB $85
	2639	+ FCC 'B/SC' ; 'B/SCR' : (blocks/screen)
	2640	+ FCB $D2
	2641	+ FDB BBUF-8
	2642	+BSCR FDB DOCON
	2643	+ FDB SCRSZ/SECTSZ
	2644	+* Hardcoded in 6800 model as:
	2645	+* FDB 8
	2646	+* blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
	2647	+*
	2648	+* ======>> 61 <<
	2649	+* ( n --- adr )
	2650	+* Calculate the address of entry (#n/2) in the boot-up parameter table.
	2651	+* (Adds the base of the boot-up table to n.)
	2652	+ FCB $87
	2653	+ FCC '+ORIGI' ; '+ORIGIN'
	2654	+ FCB $CE
	2655	+ FDB BSCR-8
	2656	+PORIG FDB DOCOL,LIT,ORIG,PLUS
	2657	+ FDB SEMIS
	2658	+*
	2659	+* ######>> screen 36 <<
	2660	+* ======>> 62 <<
	2661	+* ( n --- adr )
	2662	+* This is the per-task variable recording the initial parameter stack pointer.
	2663	+ FCB $82
	2664	+ FCC 'S' ; 'S0'
	2665	+ FCB $B0
	2666	+ FDB PORIG-10
	2667	+SZERO FDB DOUSER
	2668	+ FDB XSPZER-UORIG
	2669	+*
	2670	+* ======>> 63 <<
	2671	+* ( n --- adr )
	2672	+* This is the per-task variable recording the initial return stack pointer.
	2673	+ FCB $82
	2674	+ FCC 'R' ; 'R0'
	2675	+ FCB $B0
	2676	+ FDB SZERO-5
	2677	+RZERO FDB DOUSER
	2678	+ FDB XRZERO-UORIG
	2679	+*
	2680	+* ======>> 64 <<
	2681	+* ( --- vadr )
	2682	+* Terminal Input Buffer address.
	2683	+* Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
	2684	+ FCB $83
	2685	+ FCC 'TI' ; 'TIB'
	2686	+ FCB $C2
	2687	+ FDB RZERO-5
	2688	+TIB FDB DOUSER
	2689	+ FDB XTIB-UORIG
	2690	+*
	2691	+* ======>> 65 <<
	2692	+* ( --- maxnamewidth )
	2693	+* This is the maximum width to which symbol names will be recorded.
	2694	+ FCB $85
	2695	+ FCC 'WIDT' ; 'WIDTH'
	2696	+ FCB $C8
	2697	+ FDB TIB-6
	2698	+WIDTH FDB DOUSER
	2699	+ FDB XWIDTH-UORIG
	2700	+*
	2701	+* ======>> 66 <<
	2702	+* ( --- vadr )
	2703	+* Availability of error messages on disk.
	2704	+* Contains 1 if messages available,
	2705	+* 0 if not,
	2706	+* -1 if a disk error has occurred.
	2707	+ FCB $87
	2708	+ FCC 'WARNIN' ; 'WARNING'
	2709	+ FCB $C7
	2710	+ FDB WIDTH-8
	2711	+WARN FDB DOUSER
	2712	+ FDB XWARN-UORIG
	2713	+*
	2714	+* ======>> 67 <<
	2715	+* ( --- vadr )
	2716	+* Boundary for FORGET.
	2717	+ FCB $85
	2718	+ FCC 'FENC' ; 'FENCE'
	2719	+ FCB $C5
	2720	+ FDB WARN-10
	2721	+FENCE FDB DOUSER
	2722	+ FDB XFENCE-UORIG
	2723	+*
	2724	+* ======>> 68 <<
	2725	+* ( --- vadr )
	2726	+* Dictionary pointer, fetched by HERE.
	2727	+ FCB $82
	2728	+ FCC 'D' ; 'DP' : points to first free byte at end of dictionary
	2729	+ FCB $D0
	2730	+ FDB FENCE-8
	2731	+DICTPT FDB DOUSER
	2732	+ FDB XDICTP-UORIG
	2733	+*
	2734	+* ======>> 68.5 <<
	2735	+* ( --- vadr ) ******* Need to check what this is!
	2736	+* Used in maintaining vocabularies.
	2737	+* I think it points to the "parent" vocabulary, but I'm not sure.
	2738	+* Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
	2739	+ FCB $88
	2740	+ FCC 'VOC-LIN' ; 'VOC-LINK'
	2741	+ FCB $CB
	2742	+ FDB DICTPT-5
	2743	+VOCLIN FDB DOUSER
	2744	+ FDB XVOCL-UORIG
	2745	+*
	2746	+* ======>> 69 <<
	2747	+* ( --- vadr )
	2748	+* Disk block being interpreted.
	2749	+* Zero refers to terminal.
	2750	+* ****** Should be made a 32 bit user variable! ******
	2751	+* But the base system needs to have full 32 bit support, div and mul, etc.
	2752	+* before we can do that.
	2753	+ FCB $83
	2754	+ FCC 'BL' ; 'BLK'
	2755	+ FCB $CB
	2756	+ FDB VOCLIN-11
	2757	+BLK FDB DOUSER
	2758	+ FDB XBLK-UORIG
	2759	+*
	2760	+* ======>> 70 <<
	2761	+* ( --- vadr )
	2762	+* Input buffer offset/cursor.
	2763	+ FCB $82
	2764	+ FCC 'I' ; 'IN' : scan pointer for input line buffer
	2765	+ FCB $CE
	2766	+ FDB BLK-6
	2767	+IN FDB DOUSER
	2768	+ FDB XIN-UORIG
	2769	+*
	2770	+* ======>> 71 <<
	2771	+* ( --- vadr )
	2772	+* Output buffer offset/cursor.
	2773	+ FCB $83
	2774	+ FCC 'OU' ; 'OUT'
	2775	+ FCB $D4
	2776	+ FDB IN-5
	2777	+OUT FDB DOUSER
	2778	+ FDB XOUT-UORIG
	2779	+*
	2780	+* ======>> 72 <<
	2781	+* ( --- vadr )
	2782	+* Screen currently being edited, once we have an editor running.
	2783	+ FCB $83
	2784	+ FCC 'SC' ; 'SCR'
	2785	+ FCB $D2
	2786	+ FDB OUT-6
	2787	+SCR FDB DOUSER
	2788	+ FDB XSCR-UORIG
	2789	+* ######>> screen 37 <<
	2790	+*
	2791	+* ======>> 73 <<
	2792	+* ( --- vadr )
	2793	+* Sector offset for LOADing screens,
	2794	+* set by DRIVE to make a new drive the default.
	2795	+* This should also be 32 bit or bigger.
	2796	+ FCB $86
	2797	+ FCC 'OFFSE' ; 'OFFSET'
	2798	+ FCB $D4
	2799	+ FDB SCR-6
	2800	+OFSET FDB DOUSER
	2801	+ FDB XOFSET-UORIG
	2802	+*
	2803	+* ======>> 74 <<
	2804	+* ( --- vadr )
	2805	+* Current context of interpretation (vocabulary root).
	2806	+ FCB $87
	2807	+ FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
	2808	+ FCB $D4
	2809	+ FDB OFSET-9
	2810	+CONTXT FDB DOUSER
	2811	+ FDB XCONT-UORIG
	2812	+*
	2813	+* ======>> 75 <<
	2814	+* ( --- vadr )
	2815	+* Current context of definition (vocabulary root).
	2816	+ FCB $87
	2817	+ FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
	2818	+ FCB $D4
	2819	+ FDB CONTXT-10
	2820	+CURENT FDB DOUSER
	2821	+ FDB XCURR-UORIG
	2822	+*
	2823	+* ======>> 76 <<
	2824	+* ( --- vadr )
	2825	+* Compiler/interpreter state.
	2826	+ FCB $85
	2827	+ FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
	2828	+ FCB $C5
	2829	+ FDB CURENT-10
	2830	+STATE FDB DOUSER
	2831	+ FDB XSTATE-UORIG
	2832	+*
	2833	+* ======>> 77 <<
	2834	+* ( --- vadr )
	2835	+* Numeric conversion base.
	2836	+ FCB $84
	2837	+ FCC 'BAS' ; 'BASE' : number base for all input & output
	2838	+ FCB $C5
	2839	+ FDB STATE-8
	2840	+BASE FDB DOUSER
	2841	+ FDB XBASE-UORIG
	2842	+*
	2843	+* ======>> 78 <<
	2844	+* ( --- vadr )
	2845	+* Decimal point location for output.
	2846	+ FCB $83
	2847	+ FCC 'DP' ; 'DPL'
	2848	+ FCB $CC
	2849	+ FDB BASE-7
	2850	+DPL FDB DOUSER
	2851	+ FDB XDPL-UORIG
	2852	+*
	2853	+* ======>> 79 <<
	2854	+* ( --- vadr )
	2855	+* Field width for I/O formatting.
	2856	+ FCB $83
	2857	+ FCC 'FL' ; 'FLD'
	2858	+ FCB $C4
	2859	+ FDB DPL-6
	2860	+FLD FDB DOUSER
	2861	+ FDB XFLD-UORIG
	2862	+*
	2863	+* ======>> 80 <<
	2864	+* ( --- vadr )
	2865	+* Compiler stack mark for stack check.
	2866	+ FCB $83
	2867	+ FCC 'CS' ; 'CSP'
	2868	+ FCB $D0
	2869	+ FDB FLD-6
	2870	+CSP FDB DOUSER
	2871	+ FDB XCSP-UORIG
	2872	+*
	2873	+* ======>> 81 <<
	2874	+* ( --- vadr )
	2875	+* Editing cursor location.
	2876	+ FCB $82
	2877	+ FCC 'R' ; 'R#'
	2878	+ FCB $A3
	2879	+ FDB CSP-6
	2880	+RNUM FDB DOUSER
	2881	+ FDB XRNUM-UORIG
	2882	+*
	2883	+* ======>> 82 <<
	2884	+* ( --- vadr )
	2885	+* Pointer to last HELD character in PAD.
	2886	+ FCB $83
	2887	+ FCC 'HL' ; 'HLD'
	2888	+ FCB $C4
	2889	+ FDB RNUM-5
	2890	+HLD FDB DOCON
	2891	+ FDB XHLD
	2892	+*
	2893	+* ======>> 82.5 <<== SPECIAL
	2894	+* ( --- vadr )
	2895	+* Line width of active terminal.
	2896	+ FCB $87
	2897	+ FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
	2898	+ FCB $D3
	2899	+ FDB HLD-6
	2900	+COLUMS FDB DOUSER
	2901	+ FDB XCOLUM-UORIG
	2902	+*
	2903	+* ######>> screen 38 <<
	2904	+**
	2905	+** An INCREMENTER probably should not be defined without a defined CONSTANT?
	2906	+**
	2907	+** Make an INCREMENTER compiling word (not in model):
	2908	+** ( n --- )
	2909	+** { n INCREMENTER name } typical input
	2910	+** CREATE a header and compile the increment constant,
	2911	+** then overwrite the header with a call to DOINC.
	2912	+* FCB $8B
	2913	+* FCC 'INCREMENTE' ; 'INCREMENTER'
	2914	+* FCB $D2
	2915	+* FDB COLUMS-10
	2916	+* INCR FDB DOCOL,CON,PSCODE
	2917	+** ( n --- ninc )
	2918	+** Characteristic of an INCREMENTER.
	2919	+** This is too naive:
	2920	+* DOINC LDD ,U
	2921	+* ADDD NATWID,X ; Add the increment.
	2922	+* STD ,U
	2923	+* LBRA NEXT
	2924	+* Compiling word should check that it is compiling a CONSTANT.
	2925	+*
	2926	+* ======>> 83 <<
	2927	+* ( n --- n+1 )
	2928	+ FCB $82
	2929	+ FCC '1' ; '1+'
	2930	+ FCB $AB
	2931	+ FDB COLUMS-10
	2932	+* Using the model keeps things semantically connected for other processors:
	2933	+ONEP FDB DOCOL,ONE,PLUS
	2934	+ FDB SEMIS
	2935	+** Greedy alternative:
	2936	+* ONEP FDB *+NATWID
	2937	+* LDD ,U
	2938	+* ADDD ONEV,PCR
	2939	+* STD ,U
	2940	+* LBRA NEXT
	2941	+* Naive alternative:
	2942	+* ONEP FDB DOINC
	2943	+* FDB 1
	2944	+* Naive alternative:
	2945	+* ONEP FDB *+NATWID
	2946	+* LDD ,U
	2947	+* ADDD #1 ; It's hard to imagine 1+ being other than 1.
	2948	+* STD ,U
	2949	+* LBRA NEXT
	2950	+*
	2951	+* ======>> 84 <<
	2952	+* ( n --- n+2 )
	2953	+ FCB $82
	2954	+ FCC '2' ; '2+'
	2955	+ FCB $AB
	2956	+ FDB ONEP-5
	2957	+* Using the model keeps things semantically connected for other processors:
	2958	+TWOP FDB DOCOL,TWO,PLUS
	2959	+ FDB SEMIS
	2960	+** Greedy alternative:
	2961	+* TWOP FDB *+NATWID
	2962	+* LDD ,U
	2963	+* ADDD TWOV,PCR ; See NAT+ (NATP)
	2964	+* STD ,U
	2965	+* LBRA NEXT
	2966	+* Naive alternative:
	2967	+* TWOP FDB DOINC
	2968	+* FDB 2
	2969	+* Naive alternative:
	2970	+* TWOP FDB *+NATWID
	2971	+* LDD ,U
	2972	+* ADDD #2 ; See NAT+ (NATP)
	2973	+* STD ,U
	2974	+* LBRA NEXT
	2975	+*
	2976	+* ======>> 85 <<
	2977	+* ( --- adr )
	2978	+* Get the DICTPT allocation, like a USER constant.
	2979	+* Should check the stack and heap for collision.
	2980	+ FCB $84
	2981	+ FCC 'HER' ; 'HERE'
	2982	+ FCB $C5
	2983	+ FDB TWOP-5
	2984	+HERE FDB DOCOL,DICTPT,AT
	2985	+ FDB SEMIS
	2986	+*
	2987	+* ======>> 86 <<
	2988	+* ( n --- )
	2989	+* Increase/decrease heap (add n to DP),
	2990	+* Should ERROR check stack/heap.
	2991	+ FCB $85
	2992	+ FCC 'ALLO' ; 'ALLOT'
	2993	+ FCB $D4
	2994	+ FDB HERE-7
	2995	+ALLOT FDB DOCOL,DICTPT,PSTORE
	2996	+ FDB SEMIS
	2997	+*
	2998	+* ======>> 87 <<
	2999	+* ( n --- )
	3000	+* Store word n at DP++,
	3001	+* Should ERROR check stack/heap.
	3002	+ FCB $81 ; , (COMMA)
	3003	+ FCB $AC
	3004	+ FDB ALLOT-8
	3005	+COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT
	3006	+ FDB SEMIS
	3007	+* COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
	3008	+* FDB SEMIS
	3009	+*
	3010	+* ======>> 88 <<
	3011	+* ( b --- )
	3012	+* Store byte b at DP+,
	3013	+* Should ERROR check stack/heap.
	3014	+ FCB $82
	3015	+ FCC 'C' ; 'C,'
	3016	+ FCB $AC
	3017	+ FDB COMMA-4
	3018	+CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
	3019	+ FDB SEMIS
	3020	+*
	3021	+* ======>> 89 <<
	3022	+* ( n1 n2 --- n1-n2 )
	3023	+* Subtract top two words.
	3024	+ FCB $81 ; -
	3025	+ FCB $AD
	3026	+ FDB CCOMM-5
	3027	+SUB FDB *+NATWID
	3028	+ LDD NATWID,U ; #2~6
	3029	+ SUBD ,U++ ; #2~9
	3030	+ STD ,U ; #2~5
	3031	+ LBRA NEXT ; #1~5 = #7~25
	3032	+* SUB FDB DOCOL,MINUS,PLUS
	3033	+* FDB SEMIS ; Costs 6 bytes and lots of cycles.
	3034	+*
	3035	+* ======>> 90 <<
	3036	+* ( n1 n2 --- n1==n2 )
	3037	+* Return flag true if n1 and n2 are equal, otherwise false.
	3038	+ FCB $81 =
	3039	+ FCB $BD
	3040	+ FDB SUB-4
	3041	+EQUAL FDB DOCOL,SUB,ZEQU
	3042	+ FDB SEMIS
	3043	+*
	3044	+* ======>> 91 <<
	3045	+* ( n1 n2 --- n1<n2 )
	3046	+* Return flag true if n1 is less than n2, otherwise false.
	3047	+ FCB $81 <
	3048	+ FCB $BC
	3049	+ FDB EQUAL-4
	3050	+LESS FDB *+NATWID
	3051	+ LDD NATWID,U
	3052	+ SUBD ,U++
	3053	+ BGE FALSE
	3054	+TRUE LDD #1
	3055	+ STD ,U
	3056	+ LBRA NEXT
	3057	+FALSE LDD #0
	3058	+ STD ,U
	3059	+ LBRA NEXT
	3060	+* PULS A ;
	3061	+* PULS B ;
	3062	+* TFR S,X ; TSX :
	3063	+* CMPA 0,X
	3064	+* LEAS 1,S ;
	3065	+* BGT LESST
	3066	+* BNE LESSF
	3067	+* CMPB 1,X ; Why not sub, sbc, bge?
	3068	+* BHI LESST
	3069	+* LESSF CLRB ;
	3070	+* BRA LESSX
	3071	+* LESST LDB #1
	3072	+* LESSX CLRA ;
	3073	+* LEAS 1,S ;
	3074	+* JMP PUSHBA
	3075	+*
	3076	+* ======>> 92 <<
	3077	+* ( n1 n2 --- n1>n2 )
	3078	+* Return flag true if n1 is greater than n2, false otherwise.
	3079	+ FCB $81 >
	3080	+ FCB $BE
	3081	+ FDB LESS-4
	3082	+GREAT FDB DOCOL,SWAP,LESS
	3083	+ FDB SEMIS
	3084	+*
	3085	+* ======>> 93 <<
	3086	+* ( n1 n2 n3 --- n2 n3 n1 )
	3087	+* Rotate the top three words on stack,
	3088	+* bringing the third word to the top.
	3089	+ FCB $83
	3090	+ FCC 'RO' ; 'ROT'
	3091	+ FCB $D4
	3092	+ FDB GREAT-4
	3093	+ROT FDB *+NATWID
	3094	+ PSHS Y
	3095	+ PULU D,X,Y
	3096	+ PSHU D,X
	3097	+ PSHU Y
	3098	+ PULS Y
	3099	+ LBRA NEXT
	3100	+* ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
	3101	+* FDB SEMIS
	3102	+*
	3103	+* ======>> 94 <<
	3104	+* ( --- )
	3105	+* EMIT a SPACE.
	3106	+ FCB $85
	3107	+ FCC 'SPAC' ; 'SPACE'
	3108	+ FCB $C5
	3109	+ FDB ROT-6
	3110	+SPACE FDB DOCOL,BL,EMIT
	3111	+ FDB SEMIS
	3112	+*
	3113	+* ======>> 95 <<
	3114	+* ( n0 n1 --- min(n0,n1) )
	3115	+* Leave the minimum of the top two integers.
	3116	+* Being too greedy here, but, whatever.
	3117	+ FCB $83
	3118	+ FCC 'MI' ; 'MIN'
	3119	+ FCB $CE
	3120	+ FDB SPACE-8
	3121	+MIN FDB *+NATWID
	3122	+ PULU D
	3123	+ CMPD ,U
	3124	+ BLE MINX
	3125	+ STD ,U
	3126	+MINX LBRA NEXT
	3127	+* MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
	3128	+* FDB MIN2-*-NATWID
	3129	+* FDB SWAP
	3130	+* MIN2 FDB DROP
	3131	+* FDB SEMIS
	3132	+*
	3133	+* ======>> 96 <<
	3134	+* ( n0 n1 --- max(n0,n1) )
	3135	+* Leave the maximum of the top two integers.
	3136	+* Really should leave this as in the model.
	3137	+ FCB $83
	3138	+ FCC 'MA' ; 'MAX'
	3139	+ FCB $D8
	3140	+ FDB MIN-6
	3141	+MAX FDB *+NATWID
	3142	+ PULU D
	3143	+ CMPD ,U
	3144	+ BLE MAXX
	3145	+ STD ,U
	3146	+MAXX LBRA NEXT
	3147	+* MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
	3148	+* FDB MAX2-*-NATWID
	3149	+* FDB SWAP
	3150	+* MAX2 FDB DROP
	3151	+* FDB SEMIS
	3152	+*
	3153	+* ======>> 97 <<
	3154	+* ( 0 --- 0 )
	3155	+* ( n --- n n )
	3156	+* DUP if non-zero.
	3157	+ FCB $84
	3158	+ FCC '-DU' ; '-DUP'
	3159	+ FCB $D0
	3160	+ FDB MAX-6
	3161	+DDUP FDB *+NATWID ; Just being greedy for speed.
	3162	+ LDD ,U
	3163	+ BEQ DDUPX
	3164	+ PSHU D
	3165	+DDUPX LBRA NEXT
	3166	+* DDUP FDB DOCOL,DUP,ZBRAN
	3167	+* FDB DDUP2-*-NATWID
	3168	+* FDB DUP
	3169	+* DDUP2 FDB SEMIS
	3170	+*
	3171	+* ######>> screen 39 <<
	3172	+* ======>> 98.1 <<
	3173	+* Supplemental:
	3174	+* ( n<0 --- -1 )
	3175	+* ( n>=~ --- 1 )
	3176	+* Change top integer to its sign.
	3177	+ FCB $86
	3178	+ FCC 'SIGNU' ; 'SIGNUM'
	3179	+ FCB $CD
	3180	+ FDB DDUP-7
	3181	+SIGNUM FDB *+NATWID
	3182	+SIGNUE LDB #1
	3183	+ LDA ,U
	3184	+ BPL SIGNUP
	3185	+ NEGB
	3186	+SIGNUP SEX ; Couldn't they have called SignEXtend EXT instead?
	3187	+ STD ,U ; Am I too much of a prude?
	3188	+ LBRA NEXT
	3189	+* 6800 model version should be something like this:
	3190	+* LDB #1
	3191	+* CLRA
	3192	+* TSX
	3193	+* TST ,X
	3194	+* BPL SIGNUP
	3195	+* NEGB
	3196	+* COMA
	3197	+* SIGNUP JMP STABX
	3198	+*
	3199	+* ======>> 98 <<
	3200	+* ( adr1 direction --- adr2 )
	3201	+* TRAVERSE the symbol name.
	3202	+* If direction is 1, find the end.
	3203	+* If direction is -1, find the beginning.
	3204	+ FCB $88
	3205	+ FCC 'TRAVERS' ; 'TRAVERSE'
	3206	+ FCB $C5
	3207	+ FDB SIGNUM-9
	3208	+* TRAV FDB *+NATWID
	3209	+* BSR SIGNUE ; Convert negative to -, zero or positive to 1.
	3210	+* LDD ,U++ ; Still in D, but we have to pop it anyway.
	3211	+* LDX ,U ; If D is 1 or -1, so is B.
	3212	+* LDA #$7F
	3213	+* TRAVLP LEAX B,X ; Don't look at the one we start at.
	3214	+* CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL.
	3215	+* BCC TRAVLP
	3216	+* TRAVDN STX ,U
	3217	+* LBRA NEXT
	3218	+* Doing this in 6809 just because it can be done was getting too greedy.
	3219	+TRAV FDB DOCOL,SWAP
	3220	+TRAV2 FDB OVER,PLUS,LIT8
	3221	+ FCB $7F
	3222	+ FDB OVER,CAT,LESS,ZBRAN
	3223	+ FDB TRAV2-*-NATWID
	3224	+ FDB SWAP,DROP
	3225	+ FDB SEMIS
	3226	+*
	3227	+* ======>> 99 <<
	3228	+* ( --- symptr )
	3229	+* Fetch CURRENT as a per-USER constant.
	3230	+ FCB $86
	3231	+ FCC 'LATES' ; 'LATEST'
	3232	+ FCB $D4
	3233	+ FDB TRAV-11
	3234	+LATEST FDB DOCOL,CURENT,AT,AT
	3235	+ FDB SEMIS
	3236	+* LATEST FDB *+NATWID
	3237	+* Getting too greedy:
	3238	+* Version 1:
	3239	+* TFR DP,A
	3240	+* CLRB
	3241	+* TFR D,X
	3242	+* LDD CURENT+NATWID,PCR
	3243	+* LDX [D,X]
	3244	+* PSHU X ; Leave the address in X.
	3245	+* LBRA NEXT
	3246	+* Version 2:
	3247	+* LEAX CURENT,PCR
	3248	+* JSR [,X]
	3249	+* PULU X
	3250	+* LDX [,X]
	3251	+* PSHU X
	3252	+* LBRA NEXT
	3253	+* Too greedy, too many smantic holes to fall through.
	3254	+* If the address at the CFA is made relative,
	3255	+* this is part of the code that would be affected
	3256	+* if it is in native CPU code.
	3257	+*
	3258	+* ======>> 100 <<
	3259	+* Wanted to do these as INCREMENTERs,
	3260	+* but I need to stick with the model as much as possible,
	3261	+* (mostly, LOL) adding code only to make the model more clear.
	3262	+* ( pfa --- lfa )
	3263	+* Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
	3264	+ FCB $83
	3265	+ FCC 'LF' ; 'LFA'
	3266	+ FCB $C1
	3267	+ FDB LATEST-9
	3268	+LFA FDB DOCOL,LIT8
	3269	+* FCB 4
	3270	+ FCB 2*NATWID
	3271	+ FDB SUB
	3272	+ FDB SEMIS
	3273	+*
	3274	+* ======>> 101 <<
	3275	+* ( pfa --- cfa )
	3276	+* Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
	3277	+ FCB $83
	3278	+ FCC 'CF' ; 'CFA'
	3279	+ FCB $C1
	3280	+ FDB LFA-6
	3281	+* CFA FDB DOCOL,TWO,SUB
	3282	+CFA FDB DOCOL,NATWC,SUB
	3283	+ FDB SEMIS
	3284	+*
	3285	+* ======>> 102 <<
	3286	+* ( pfa --- nfa )
	3287	+* Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
	3288	+ FCB $83
	3289	+ FCC 'NF' ; 'NFA'
	3290	+ FCB $C1
	3291	+ FDB CFA-6
	3292	+NFA FDB DOCOL,LIT8
	3293	+* FCB 5
	3294	+ FCB NATWID*2+1
	3295	+ FDB SUB,ONE,MINUS,TRAV
	3296	+ FDB SEMIS
	3297	+*
	3298	+* ======>> 103 <<
	3299	+* ( nfa --- pfa )
	3300	+* Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
	3301	+ FCB $83
	3302	+ FCC 'PF' ; 'PFA'
	3303	+ FCB $C1
	3304	+ FDB NFA-6
	3305	+PFA FDB DOCOL,ONE,TRAV,LIT8
	3306	+* FCB 5
	3307	+ FCB NATWID*2+1
	3308	+ FDB PLUS
	3309	+ FDB SEMIS
	3310	+*
	3311	+* ######>> screen 40 <<
	3312	+* ======>> 104 <<
	3313	+* ( --- )
	3314	+* Save the parameter stack pointer in CSP for compiler checks.
	3315	+ FCB $84
	3316	+ FCC '!CS' ; '!CSP'
	3317	+ FCB $D0
	3318	+ FDB PFA-6
	3319	+SCSP FDB DOCOL,SPAT,CSP,STORE
	3320	+ FDB SEMIS
	3321	+*
	3322	+* ======>> 105 <<
	3323	+* ( 0 n --- ) ( *** )
	3324	+* ( true n --- IN BLK ) ( anything *** nothing )
	3325	+* If flag is false, do nothing.
	3326	+* If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
	3327	+* Leaves cursor position (IN)
	3328	+* and currently loading block number (BLK) on stack, for analysis.
	3329	+*
	3330	+* This one is too important to be high-level Forth codes.
	3331	+* When we have an error, we want to disturb as little as possible.
	3332	+* But fixing that cascades through ERROR and MESSAGE
	3333	+* into the disk block system.
	3334	+* And we aren't ready for that yet.
	3335	+ FCB $86
	3336	+ FCC '?ERRO' ; '?ERROR'
	3337	+ FCB $D2
	3338	+ FDB SCSP-7
	3339	+* QERR FDB *+NATWID
	3340	+* LDD NATWID,U
	3341	+* BNE QERROR
	3342	+* LEAU 2*NATWID,U
	3343	+* LBRA NEXT
	3344	+** this doesn't work anyway: QERROR LBRA ERROR
	3345	+QERR FDB DOCOL,SWAP,ZBRAN
	3346	+ FDB QERR2-*-NATWID
	3347	+ FDB ERROR,BRAN
	3348	+ FDB QERR3-*-NATWID
	3349	+QERR2 FDB DROP
	3350	+QERR3 FDB SEMIS
	3351	+*
	3352	+* ======>> 106 <<
	3353	+* STATE is compiling:
	3354	+* ( --- ) ( *** )
	3355	+* STATE is not compiling:
	3356	+* ( --- IN BLK ) ( anything *** nothing )
	3357	+* ERROR if not compiling.
	3358	+ FCB $85
	3359	+ FCC '?COM' ; '?COMP'
	3360	+ FCB $D0
	3361	+ FDB QERR-9
	3362	+QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8
	3363	+ FCB $11
	3364	+ FDB QERR
	3365	+ FDB SEMIS
	3366	+*
	3367	+* ======>> 107 <<
	3368	+* STATE is executing:
	3369	+* ( --- ) ( *** )
	3370	+* STATE is not executing:
	3371	+* ( --- IN BLK ) ( anything *** nothing )
	3372	+* ERROR if not executing.
	3373	+ FCB $85
	3374	+ FCC '?EXE' ; '?EXEC'
	3375	+ FCB $C3
	3376	+ FDB QCOMP-8
	3377	+QEXEC FDB DOCOL,STATE,AT,LIT8
	3378	+ FCB $12
	3379	+ FDB QERR
	3380	+ FDB SEMIS
	3381	+*
	3382	+* ======>> 108 <<
	3383	+* ( n1 n1 --- ) ( *** )
	3384	+* ( n1 n2 --- IN BLK ) ( anything *** nothing )
	3385	+* ERROR if top two are unequal.
	3386	+* MESSAGE says compiled conditionals do not match.
	3387	+ FCB $86
	3388	+ FCC '?PAIR' ; '?PAIRS'
	3389	+ FCB $D3
	3390	+ FDB QEXEC-8
	3391	+QPAIRS FDB DOCOL,SUB,LIT8
	3392	+ FCB $13
	3393	+ FDB QERR
	3394	+ FDB SEMIS
	3395	+*
	3396	+* ======>> 109 <<
	3397	+* CSP and parameter stack are balanced (equal):
	3398	+* ( --- ) ( *** )
	3399	+* CSP and parameter stack are not balanced (unequal):
	3400	+* ( --- IN BLK ) ( anything *** nothing )
	3401	+* ERROR if return/control stack is not at same level as last !CSP.
	3402	+* Usually indicates that a definition has been left incomplete.
	3403	+ FCB $84
	3404	+ FCC '?CS' ; '?CSP'
	3405	+ FCB $D0
	3406	+ FDB QPAIRS-9
	3407	+QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8
	3408	+ FCB $14
	3409	+ FDB QERR
	3410	+ FDB SEMIS
	3411	+*
	3412	+* ======>> 110 <<
	3413	+* Active BLK input:
	3414	+* ( --- ) ( *** )
	3415	+* No active BLK input:
	3416	+* ( --- IN BLK ) ( anything *** nothing )
	3417	+* ERROR if not loading, i. e., if BLK is zero.
	3418	+ FCB $88
	3419	+ FCC '?LOADIN' ; '?LOADING'
	3420	+ FCB $C7
	3421	+ FDB QCSP-7
	3422	+QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8
	3423	+ FCB $16
	3424	+ FDB QERR
	3425	+ FDB SEMIS
	3426	+*
	3427	+* ######>> screen 41 <<
	3428	+* ======>> 111 <<
	3429	+* ( --- )
	3430	+* Compile an in-line literal value from the instruction stream.
	3431	+ FCB $87
	3432	+ FCC 'COMPIL' ; 'COMPILE'
	3433	+ FCB $C5
	3434	+ FDB QLOAD-11
	3435	+* COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
	3436	+* COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
	3437	+COMPIL FDB DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
	3438	+ FDB SEMIS
	3439	+*
	3440	+* ======>> 112 <<
	3441	+* ( --- ) P
	3442	+* Clear the compile state bit(s) (shift to interpret).
	3443	+ FCB $C1 [ immediate
	3444	+ FCB $DB
	3445	+ FDB COMPIL-10
	3446	+LBRAK FDB DOCOL,ZERO,STATE,STORE
	3447	+ FDB SEMIS
	3448	+*
	3449	+* ======>> 113 <<
	3450	+*
	3451	+STCOMP EQU $C0
	3452	+* ( --- )
	3453	+* Set the compile state bit(s) (shift to compile).
	3454	+ FCB $81 ]
	3455	+ FCB $DD
	3456	+ FDB LBRAK-4
	3457	+RBRAK FDB DOCOL,LIT8
	3458	+ FCB STCOMP
	3459	+ FDB STATE,STORE
	3460	+ FDB SEMIS
	3461	+*
	3462	+* ======>> 114 <<
	3463	+* ( --- )
	3464	+* Toggle SMUDGE bit of LATEST definition header,
	3465	+* to hide it until defined or reveal it after definition.
	3466	+ FCB $86
	3467	+ FCC 'SMUDG' ; 'SMUDGE'
	3468	+ FCB $C5
	3469	+ FDB RBRAK-4
	3470	+SMUDGE FDB DOCOL,LATEST,LIT8
	3471	+ FCB FSMUDG
	3472	+ FDB TOGGLE
	3473	+ FDB SEMIS
	3474	+*
	3475	+* ======>> 115 <<
	3476	+* ( --- )
	3477	+* Set the conversion base to sixteen (b00010000).
	3478	+ FCB $83
	3479	+ FCC 'HE' ; 'HEX'
	3480	+ FCB $D8
	3481	+ FDB SMUDGE-9
	3482	+HEX FDB DOCOL
	3483	+ FDB LIT8
	3484	+ FCB 16 ; decimal sixteen
	3485	+ FDB BASE,STORE
	3486	+ FDB SEMIS
	3487	+*
	3488	+* ======>> 116 <<
	3489	+* ( --- )
	3490	+* Set the conversion base to ten (b00001010).
	3491	+ FCB $87
	3492	+ FCC 'DECIMA' ; 'DECIMAL'
	3493	+ FCB $CC
	3494	+ FDB HEX-6
	3495	+DEC FDB DOCOL
	3496	+ FDB LIT8
	3497	+ FCB 10 ; decimal ten
	3498	+ FDB BASE,STORE
	3499	+ FDB SEMIS
	3500	+*
	3501	+* ######>> screen 42 <<
	3502	+* ======>> 117 <<
	3503	+* ( --- ) ( IP *** )
	3504	+* Pop the saved IP and use it to
	3505	+* compile the latest symbol as a reference to a ;CODE definition;
	3506	+* overwrite the code field of the symbol found by LATEST
	3507	+* with the address of the low-level characteristic code
	3508	+* provided in the defining definition.
	3509	+* Look closely at where things return, consider the operation of R> and >R .
	3510	+*
	3511	+* The machine-level code which follows (;CODE) in the instruction stream
	3512	+* is not executed by the defining symbol,
	3513	+* but becomes the characteristic of the defined symbol.
	3514	+* This is the usual way to generate the characteristics of VARIABLEs,
	3515	+* CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
	3516	+*
	3517	+* Finally, note that, if code shifts from low level back to high
	3518	+* (native CPU machine code calling into a list of FORTH codes),
	3519	+* the low level code can't just call a high-level definition.
	3520	+* Leaf definitions can directly call other leaf definitions,
	3521	+* but not non-leafs.
	3522	+* It will need an anonymous list, probably embedded in the low-level code,
	3523	+* and Y and X will have to be set appropriately before entering the list.
	3524	+ FCB $87
	3525	+ FCC '(;CODE' ; '(;CODE)'
	3526	+ FCB $A9
	3527	+ FDB DEC-10
	3528	+* PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
	3529	+PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
	3530	+ FDB LATEST,PFA,CFA,STORE
	3531	+ FDB SEMIS
	3532	+*
	3533	+* ======>> 118 <<
	3534	+* ( --- ) P
	3535	+* ?CSP to see if there are loose ends in the defining definition
	3536	+* before shifting to the assembler,
	3537	+* compile (;CODE) in the defining definition's instruction stream,
	3538	+* shift to interpreting,
	3539	+* make the ASSEMBLER vocabulary current,
	3540	+* and !CSP to mark the stack
	3541	+* in preparation for assembling low-level code.
	3542	+* Note that ;CODE, unlike DOES>, is IMMEDIATE,
	3543	+* and compiles (;CODE),
	3544	+* which will do the actual work of changing
	3545	+* the LATEST definition's characteristic when the defining word runs.
	3546	+* Assembly is done by the interpreter, rather than the compiler.
	3547	+* I could have avoided the anomalous three-byte code fields by
	3548	+*
	3549	+* Note that the ASSEMBLER is not part of the model (at this time).
	3550	+* That means that, until the assembler is ready,
	3551	+* if you want to define low-level words,
	3552	+* you have to poke (comma) in hand-assembled stuff.
	3553	+*
	3554	+ FCB $C5 immediate
	3555	+ FCC ';COD' ; ';CODE'
	3556	+ FCB $C5
	3557	+ FDB PSCODE-10
	3558	+SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
	3559	+ FDB SEMIS
	3560	+* note: "QSTACK" will be replaced by "ASSEMBLER" later
	3561	+*
	3562	+* ######>> screen 43 <<
	3563	+* ======>> 119 <<
	3564	+* ( --- ) C
	3565	+* Make the word currently being defined
	3566	+* build a header for DOES> definitions.
	3567	+* Actually just compiles a CONSTANT zero
	3568	+* which can be overwritten later by DOES>.
	3569	+* Since the fig models were established, this technique has been deprecated.
	3570	+*
	3571	+* Note that <BUILDS is not IMMEDIATE,
	3572	+* and therefore executes during a definition's run-time,
	3573	+* rather than its compile-time.
	3574	+* It is not intended to be used directly,
	3575	+* but rather so that one definition word can build another.
	3576	+* Also, note that nothing particularly special happens
	3577	+* in the defining definition until DOES> executes.
	3578	+* The name <BUILDS is intended to be a reminder of what is about to occur.
	3579	+*
	3580	+* <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
	3581	+ FCB $87
	3582	+ FCC '<BUILD' ; '<BUILDS'
	3583	+ FCB $D3
	3584	+ FDB SEMIC-8
	3585	+BUILDS FDB DOCOL,ZERO,CON
	3586	+ FDB SEMIS
	3587	+*
	3588	+* ======>> 120 <<
	3589	+* ( --- ) ( IP *** ) C
	3590	+* Define run-time behavior of definitions compiled/defined
	3591	+* by a high-level defining definition --
	3592	+* the FORTH equivalent of a compiler-compiler.
	3593	+* DOES> assumes that the LATEST symbol table entry
	3594	+* has at least one word of parameter field,
	3595	+* which <BUILDS provides.
	3596	+* Note that DOES> is also not IMMEDIATE.
	3597	+*
	3598	+* When the defining word containing DOES> executes the DOES> icode,
	3599	+* it overwrites the LATEST symbol's CFA with jsr <XDOES,
	3600	+* overwrites the first word of that symbol's parameter field with its own IP,
	3601	+* and pops the previous IP from the return stack.
	3602	+* The icodes which follow DOES> in the stream
	3603	+* do not execute at the defining word's run-time.
	3604	+*
	3605	+* Examining XDOES in the virtual machine shows
	3606	+* that the defined word will execute those icodes
	3607	+* which follow DOES> at its own run-time.
	3608	+*
	3609	+* The advantage of this kind of behaviour,
	3610	+* which you will also note in ;CODE,
	3611	+* is that the defined word can contain
	3612	+* both operations and data to be operated on.
	3613	+* This is how FORTH data objects define their own behavior.
	3614	+*
	3615	+* Finally, note that the effective parameter field for DOES> definitions
	3616	+* starts two NATWID words after the CFA, instead of just one
	3617	+* (four bytes instead of two in a sixteen-bit addressing Forth).
	3618	+*
	3619	+* VOCABULARYs will use this. See definition of word FORTH.
	3620	+ FCB $85
	3621	+ FCC 'DOES' ; 'DOES>'
	3622	+ FCB $BE
	3623	+ FDB BUILDS-10
	3624	+* DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
	3625	+DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
	3626	+ FDB LATEST,PFA,STORE
	3627	+ FDB PSCODE
	3628	+*
	3629	+* ( --- PFA+NATWID ) ( *** IP )
	3630	+* Characteristic of a DOES> defined word.
	3631	+* The characteristics of DOES> definitions are written in high-level
	3632	+* Forth codes rather than native CPU machine level code.
	3633	+* The first parameter word points to the high-level characteristic.
	3634	+* This routine's job is to push the IP,
	3635	+* load the high level characteristic pointer in IP,
	3636	+* and leave the address following the characteristic pointer on the stack
	3637	+* so the parameter field can be accessed.
	3638	+DODOES PSHS Y ; Save/nest the current IP on the return stack.
	3639	+ LDY NATWID,X ; First parameter is new IP.
	3640	+ LEAX 2*NATWID,X ; Address of second parameter.
	3641	+ PSHU X
	3642	+ LBRA NEXT ; No return, just jump.
	3643	+*
	3644	+* From the 6800 model:
	3645	+* DODOES LDA IP
	3646	+* LDB IP+1
	3647	+* LDX RP make room on return stack
	3648	+* LEAX -1,X ;
	3649	+* LEAX -1,X ;
	3650	+* STX RP
	3651	+* STA 2,X push return address
	3652	+* STB 3,X
	3653	+* LDX W get addr of pointer to run-time code
	3654	+* LEAX 1,X ;
	3655	+* LEAX 1,X ;
	3656	+* STX N stash it in scratch area
	3657	+* LDX 0,X get new IP
	3658	+* STX IP
	3659	+* CLRA ; get address of parameter
	3660	+* LDB #2
	3661	+* ADDB N+1
	3662	+* ADCA N
	3663	+* PSHS B ; and push it on data stack
	3664	+* PSHS A ;
	3665	+* JMP NEXT2
	3666	+*
	3667	+* ######>> screen 44 <<
	3668	+* ======>> 121 <<
	3669	+* ( strptr --- strptr+1 count )
	3670	+* Convert counted string to string and count.
	3671	+* (Fetch the byte at strptr, post-increment.)
	3672	+ FCB $85
	3673	+ FCC 'COUN' ; 'COUNT'
	3674	+ FCB $D4
	3675	+ FDB DOES-8
	3676	+COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
	3677	+ FDB SEMIS
	3678	+*
	3679	+* ======>> 122 <<
	3680	+* ( strptr count --- )
	3681	+* EMIT count characters at strptr.
	3682	+ FCB $84
	3683	+ FCC 'TYP' ; 'TYPE'
	3684	+ FCB $C5
	3685	+ FDB COUNT-8
	3686	+TYPE FDB DOCOL,DDUP,ZBRAN
	3687	+ FDB TYPE3-*-NATWID
	3688	+ FDB OVER,PLUS,SWAP,XDO
	3689	+TYPE2 FDB I,CAT,EMIT,XLOOP
	3690	+ FDB TYPE2-*-NATWID
	3691	+ FDB BRAN
	3692	+ FDB TYPE4-*-NATWID
	3693	+TYPE3 FDB DROP
	3694	+TYPE4 FDB SEMIS
	3695	+*
	3696	+* ======>> 123 <<
	3697	+* ( strptr count1 --- strptr count2 )
	3698	+* Supress trailing blanks (subtract count of trailing blanks from strptr).
	3699	+ FCB $89
	3700	+ FCC '-TRAILIN' ; '-TRAILING'
	3701	+ FCB $C7
	3702	+ FDB TYPE-7
	3703	+DTRAIL FDB DOCOL,DUP,ZERO,XDO
	3704	+DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
	3705	+ FDB SUB,ZBRAN
	3706	+ FDB DTRAL3-*-NATWID
	3707	+ FDB LEAVE,BRAN
	3708	+ FDB DTRAL4-*-NATWID
	3709	+DTRAL3 FDB ONE,SUB
	3710	+DTRAL4 FDB XLOOP
	3711	+ FDB DTRAL2-*-NATWID
	3712	+ FDB SEMIS
	3713	+*
	3714	+* ======>> 124 <<
	3715	+* ( --- )
	3716	+* TYPE counted string out of instruction stream (updating IP).
	3717	+ FCB $84
	3718	+ FCC '(."' ; '(.")'
	3719	+ FCB $A9
	3720	+ FDB DTRAIL-12
	3721	+* PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
	3722	+* PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
	3723	+PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP ; IP/Y is post-inc.
	3724	+ FDB FROMR,PLUS,TOR,TYPE
	3725	+ FDB SEMIS
	3726	+*
	3727	+* ======>> 125 <<
	3728	+* ( --- ) P
	3729	+* { ." something-to-be-printed " } typical input
	3730	+* Use WORD to parse to trailing quote;
	3731	+* if compiling, compile XDOTQ and string parsed,
	3732	+* otherwise, TYPE string.
	3733	+ FCB $C2 immediate
	3734	+ FCC '.' ; '."'
	3735	+ FCB $A2
	3736	+ FDB PDOTQ-7
	3737	+DOTQ FDB DOCOL
	3738	+ FDB LIT8
	3739	+ FCB $22 ascii quote
	3740	+ FDB STATE,AT,ZBRAN
	3741	+ FDB DOTQ1-*-NATWID
	3742	+ FDB COMPIL,PDOTQ,WORD
	3743	+ FDB HERE,CAT,ONEP,ALLOT,BRAN
	3744	+ FDB DOTQ2-*-NATWID
	3745	+DOTQ1 FDB WORD,HERE,COUNT,TYPE
	3746	+DOTQ2 FDB SEMIS
	3747	+*
	3748	+* ######>> screen 45 <<
	3749	+* ======>> 126 <<== MACHINE DEPENDENT
	3750	+* ( --- ) ( *** )
	3751	+* ( --- IN BLK ) ( anything *** nothing )
	3752	+* ERROR if parameter stack out of bounds.
	3753	+*
	3754	+* But checking whether the stack is in bounds or not
	3755	+* really should not use the stack.
	3756	+* And there really should be a ?RSTACK, as well.
	3757	+ FCB $86
	3758	+ FCC '?STAC' ; '?STACK'
	3759	+ FCB $CB
	3760	+ FDB DOTQ-5
	3761	+QSTACK FDB DOCOL,LIT8
	3762	+* FCB $12
	3763	+ FCB SINIT-ORIG
	3764	+* But why use that instead of XSPZER (S0)?
	3765	+* Multi-user or multi-tasking would not want that.
	3766	+* CMPU <XSPZER
	3767	+* FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
	3768	+ FDB PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
	3769	+ FDB QERR
	3770	+* prints 'empty stack'
	3771	+*
	3772	+QSTAC2 FDB SPAT
	3773	+* Here, we compare with a value at least 128
	3774	+* higher than dict. ptr. (DICTPT)
	3775	+* FDB HERE,LIT8
	3776	+* FCB $80 ; This is a rough check anyway, leave it as is.
	3777	+* But shouldn't it be the terminal width?
	3778	+ FDB HERE,COLUMS,AT
	3779	+ FDB PLUS,LESS,ZBRAN
	3780	+ FDB QSTAC3-*-NATWID
	3781	+ FDB TWO ; NOT the NATWID constant!
	3782	+ FDB QERR
	3783	+* prints 'full stack'
	3784	+*
	3785	+QSTAC3 FDB SEMIS
	3786	+*
	3787	+* ======>> 127 << this word's function
	3788	+* is done by ?STACK in this version
	3789	+* FCB $85
	3790	+* FCC 4,?FREE
	3791	+* FCB $C5
	3792	+* FDB QSTACK-9
	3793	+*QFREE FDB DOCOL,SPAT,HERE,LIT8
	3794	+* FCB $80
	3795	+* FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
	3796	+*
	3797	+* ######>> screen 46 <<
	3798	+* ======>> 128 <<
	3799	+* ( buffer n --- )
	3800	+* ***** Check that this is how it works here:
	3801	+* Get up to n-1 characters from the keyboard,
	3802	+* storing at buffer and echoing, with backspace editing,
	3803	+* quitting when a CR is read.
	3804	+* Terminate it with a NUL.
	3805	+ FCB $86
	3806	+ FCC 'EXPEC' ; 'EXPECT'
	3807	+ FCB $D4
	3808	+ FDB QSTACK-9
	3809	+EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
	3810	+* EXPEC2 FDB KEY,DUP,LIT8
	3811	+EXPEC2 FDB KEY
	3812	+* FDB LIT,$1C,SHOTOS ; DBG
	3813	+ FDB DUP,LIT8
	3814	+ FCB BACKSP-ORIG
	3815	+ FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing
	3816	+ FDB EXPEC3-*-NATWID
	3817	+ FDB DROP,LIT8
	3818	+ FCB 8 ( backspace character to emit )
	3819	+ FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
	3820	+ FDB TOR,SUB,BRAN
	3821	+ FDB EXPEC6-*-NATWID
	3822	+EXPEC3 FDB DUP,LIT8
	3823	+ FCB $D ( carriage return )
	3824	+ FDB EQUAL,ZBRAN
	3825	+ FDB EXPEC4-*-NATWID
	3826	+ FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
	3827	+ FDB EXPEC5-*-NATWID
	3828	+EXPEC4 FDB DUP
	3829	+EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
	3830	+EXPEC6 FDB EMIT,XLOOP
	3831	+ FDB EXPEC2-*-NATWID
	3832	+ FDB DROP
	3833	+ FDB SEMIS
	3834	+*
	3835	+* ======>> 129 <<
	3836	+* ( --- )
	3837	+* EXPECT 128 (TWID) characters to TIB.
	3838	+ FCB $85
	3839	+ FCC 'QUER' ; 'QUERY'
	3840	+ FCB $D9
	3841	+ FDB EXPECT-9
	3842	+QUERY FDB DOCOL,TIB,AT,COLUMS
	3843	+ FDB AT,EXPECT,ZERO,IN,STORE
	3844	+ FDB SEMIS
	3845	+*
	3846	+* ======>> 130 <<
	3847	+* ( --- ) P
	3848	+* End interpretation of a line or screen, and/or prepare for a new block.
	3849	+* Note that the name of this definition is an empty string,
	3850	+* so it matches on the terminating NUL in the terminal or block buffer.
	3851	+ FCB $C1 immediate < carriage return >
	3852	+ FCB $80
	3853	+ FDB QUERY-8
	3854	+NULL FDB DOCOL,BLK,AT,ZBRAN
	3855	+ FDB NULL2-*-NATWID
	3856	+ FDB ONE,BLK,PSTORE
	3857	+ FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
	3858	+ FDB ZEQU
	3859	+* check for end of screen
	3860	+ FDB ZBRAN
	3861	+ FDB NULL1-*-NATWID
	3862	+ FDB QEXEC,FROMR,DROP
	3863	+NULL1 FDB BRAN
	3864	+ FDB NULL3-*-NATWID
	3865	+NULL2 FDB FROMR,DROP
	3866	+NULL3 FDB SEMIS
	3867	+*
	3868	+* ######>> screen 47 <<
	3869	+* ======>> 133 <<
	3870	+* ( adr n b --- )
	3871	+* Fill n bytes at adr with b.
	3872	+* This relies on CMOVE having a certain lack of parameter checking,
	3873	+* where overlapping regions are not properly inverted in copy.
	3874	+* And this really should be done in low-level.
	3875	+* None of the advantages of doing things in high-level apply to fill.
	3876	+ FCB $84
	3877	+ FCC 'FIL' ; 'FILL'
	3878	+ FCB $CC
	3879	+ FDB NULL-4
	3880	+FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
	3881	+ FDB FROMR,ONE,SUB,CMOVE
	3882	+ FDB SEMIS
	3883	+*
	3884	+* ======>> 134 <<
	3885	+* ( adr n --- )
	3886	+* Fill n bytes with 0.
	3887	+ FCB $85
	3888	+ FCC 'ERAS' ; 'ERASE'
	3889	+ FCB $C5
	3890	+ FDB FILL-7
	3891	+ERASE FDB DOCOL,ZERO,FILL
	3892	+ FDB SEMIS
	3893	+*
	3894	+* ======>> 135 <<
	3895	+* ( adr n --- )
	3896	+* Fill n bytes with ASCII SPACE.
	3897	+ FCB $86
	3898	+ FCC 'BLANK' ; 'BLANKS'
	3899	+ FCB $D3
	3900	+ FDB ERASE-8
	3901	+BLANKS FDB DOCOL,BL,FILL
	3902	+ FDB SEMIS
	3903	+*
	3904	+* ======>> 136 <<
	3905	+* ( c --- )
	3906	+* Format a character at the left of the HLD output buffer.
	3907	+ FCB $84
	3908	+ FCC 'HOL' ; 'HOLD'
	3909	+ FCB $C4
	3910	+ FDB BLANKS-9
	3911	+HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
	3912	+ FDB SEMIS
	3913	+*
	3914	+* ======>> 137 <<
	3915	+* ( --- adr )
	3916	+* Give the address of the output PAD buffer.
	3917	+* PAD points to the end of a 68 byte buffer for numeric conversion.
	3918	+ FCB $83
	3919	+ FCC 'PA' ; 'PAD'
	3920	+ FCB $C4
	3921	+ FDB HOLD-7
	3922	+PAD FDB DOCOL,HERE,LIT8
	3923	+ FCB $44
	3924	+ FDB PLUS
	3925	+ FDB SEMIS
	3926	+*
	3927	+* ######>> screen 48 <<
	3928	+* ======>> 138 <<
	3929	+* ( c --- )
	3930	+* Scan a string terminated by the character c or ASCII NUL out of input;
	3931	+* store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
	3932	+* Leading c are passed over, per ENCLOSE.
	3933	+* Scans from BLK, or from TIB if BLK is zero.
	3934	+* May overwrite the numeric conversion pad,
	3935	+* if really long (length > 31) symbols are scanned.
	3936	+ FCB $84
	3937	+ FCC 'WOR' ; 'WORD'
	3938	+ FCB $C4
	3939	+ FDB PAD-6
	3940	+WORD FDB DOCOL,BLK,AT,ZBRAN
	3941	+ FDB WORD2-*-NATWID
	3942	+ FDB BLK,AT,BLOCK,BRAN
	3943	+ FDB WORD3-*-NATWID
	3944	+WORD2 FDB TIB,AT
	3945	+WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
	3946	+ FCB 34
	3947	+ FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
	3948	+ FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
	3949	+ FDB SEMIS
	3950	+*
	3951	+* ######>> screen 49 <<
	3952	+* ======>> 139 <<
	3953	+* ( d1 string --- d2 adr )
	3954	+* Convert the text at string into a number, accumulating the result into d1,
	3955	+* leaving adr pointing to the first character not converted.
	3956	+* If DPL is non-negative at entry,
	3957	+* accumulates the number of characters converted into DPL.
	3958	+ FCB $88
	3959	+ FCC '(NUMBER' ; '(NUMBER)'
	3960	+ FCB $A9
	3961	+ FDB WORD-7
	3962	+PNUMB FDB DOCOL
	3963	+PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
	3964	+ FDB PNUMB4-*-NATWID
	3965	+ FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
	3966	+ FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
	3967	+ FDB PNUMB3-*-NATWID
	3968	+ FDB ONE,DPL,PSTORE
	3969	+PNUMB3 FDB FROMR,BRAN
	3970	+ FDB PNUMB2-*-NATWID
	3971	+PNUMB4 FDB FROMR
	3972	+ FDB SEMIS
	3973	+*
	3974	+* ======>> 140 <<
	3975	+* ( ctstr --- d )
	3976	+* Convert text at ctstr to a double integer,
	3977	+* taking the 0 ERROR if the conversion is not valid.
	3978	+* If a decimal point is present,
	3979	+* accumulate the count of digits to the decimal point's right into DPL
	3980	+* (negative DPL at exit indicates single precision).
	3981	+* ctstr is a counted string
	3982	+* -- the first byte at ctstr is the length of the string,
	3983	+* but NUMBER ignores the count and expects a NUL terminator instead.
	3984	+ FCB $86
	3985	+ FCC 'NUMBE' ; 'NUMBER'
	3986	+ FCB $D2
	3987	+ FDB PNUMB-11
	3988	+NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
	3989	+ FCC "-" minus sign
	3990	+ FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
	3991	+NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
	3992	+ FDB ZBRAN
	3993	+ FDB NUMB2-*-NATWID
	3994	+ FDB DUP,CAT,LIT8
	3995	+ FCC "."
	3996	+ FDB SUB,ZERO,QERR,ZERO,BRAN
	3997	+ FDB NUMB1-*-NATWID
	3998	+NUMB2 FDB DROP,FROMR,ZBRAN
	3999	+ FDB NUMB3-*-NATWID
	4000	+ FDB DMINUS
	4001	+NUMB3 FDB SEMIS
	4002	+*
	4003	+* ======>> 141 <<
	4004	+* ( --- locptr length true ) { -FIND name } typical input
	4005	+* ( --- false )
	4006	+* Parse a word, then FIND,
	4007	+* first in the definition vocabulary,
	4008	+* then in the CONTEXT (interpretation) vocabulary, if necessary.
	4009	+* Returns what (FIND) returns, flag and optional location and length.
	4010	+ FCB $85
	4011	+ FCC '-FIN' ; '-FIND'
	4012	+ FCB $C4
	4013	+ FDB NUMB-9
	4014	+DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
	4015	+ FDB PFIND,DUP,ZEQU,ZBRAN
	4016	+ FDB DFIND2-*-NATWID
	4017	+ FDB DROP,HERE,LATEST,PFIND
	4018	+DFIND2 FDB SEMIS
	4019	+*
	4020	+* ######>> screen 50 <<
	4021	+* ======>> 142 <<
	4022	+* ( anything --- nothing ) ( anything *** nothing )
	4023	+* An indirection for ABORT, for ERROR,
	4024	+* which may be modified carefully.
	4025	+ FCB $87
	4026	+ FCC '(ABORT' ; '(ABORT)'
	4027	+ FCB $A9
	4028	+ FDB DFIND-8
	4029	+PABORT FDB DOCOL,ABORT
	4030	+ FDB SEMIS
	4031	+*
	4032	+* ======>> 143 <<
	4033	+ FCB $85
	4034	+ FCC 'ERRO' ; 'ERROR'
	4035	+ FCB $D2
	4036	+ FDB PABORT-10
	4037	+* This really should not be high level, according to best practices.
	4038	+* But fixing that cascades through MESSAGE,
	4039	+* requiring re-architecting the disk block system.
	4040	+* First, we need to get this transliteration running.
	4041	+ERROR FDB DOCOL,WARN,AT,ZLESS
	4042	+ FDB ZBRAN
	4043	+ FDB ERROR2-*-NATWID
	4044	+* note: WARNING is
	4045	+* -1 to abort,
	4046	+* 0 to print error #
	4047	+* and 1 to print error message from disc
	4048	+ FDB PABORT
	4049	+ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
	4050	+ FCB 4,7 ( bell )
	4051	+ FCC " ? "
	4052	+ FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
	4053	+ FDB SEMIS
	4054	+*
	4055	+* ======>> 144 <<
	4056	+* ( n adr --- )
	4057	+* Mask byte at adr with n.
	4058	+* Not in FIG, don't need it for 8 bit characters after all.
	4059	+* FCB $85
	4060	+* FCC 'CMAS' ; 'CMASK'
	4061	+* FCB $CB ; 'K'
	4062	+* FDB ERROR-8
	4063	+* CMASK FDB *+NATWID
	4064	+* LDX ,U++ ; adr
	4065	+* LDD ,U++ ; mask
	4066	+* ANDB ,X
	4067	+* STB ,X
	4068	+* LBRA NEXT
	4069	+*
	4070	+* ( adr --- adr )
	4071	+* Mask high bit of tail of name in PAD buffer.
	4072	+* Not in FIG, need it for 8 bit characters.
	4073	+ FCB $86
	4074	+ FCC 'IDFLA' ; 'IDFLAT'
	4075	+ FCB $D4 ; 'T'
	4076	+ FDB ERROR-8
	4077	+IDFLAT FDB *+NATWID
	4078	+ LDX ,U
	4079	+ LDB ,X ; get the count
	4080	+ ANDB #CTMASK
	4081	+ LDA B,X ; point to the tail
	4082	+ ANDA #$7F ; Clear the EndOfName flag bit.
	4083	+ STA B,X
	4084	+ LBRA NEXT
	4085	+*
	4086	+* ( symptr --- )
	4087	+* Print definition's name from its NFA.
	4088	+ FCB $83
	4089	+ FCC 'ID' ; 'ID.'
	4090	+ FCB $AE
	4091	+ FDB IDFLAT-9
	4092	+IDDOT FDB DOCOL,PAD,LIT8
	4093	+ FCB 32
	4094	+ FDB LIT8
	4095	+ FCB $5F ( underline )
	4096	+ FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
	4097	+* FDB SWAP,CMOVE,PAD,COUNT,LIT8
	4098	+ FDB SWAP,CMOVE,PAD
	4099	+ FDB IDFLAT
	4100	+ FDB COUNT,LIT8
	4101	+ FCB 31
	4102	+ FDB AND,TYPE,SPACE
	4103	+ FDB SEMIS
	4104	+*
	4105	+* ######>> screen 51 <<
	4106	+* ======>> 145 <<
	4107	+* ( --- ) { CREATE name } input
	4108	+* Parse a name (length < 32 characters) and create a header,
	4109	+* reporting first duplicate found in either the defining vocabulary
	4110	+* or the context (interpreting) vocabulary.
	4111	+* Install the header in the defining vocabulary
	4112	+* with CFA dangerously pointing to the parameter field.
	4113	+* Leave the name SMUDGEd.
	4114	+ FCB $86
	4115	+ FCC 'CREAT' ; 'CREATE'
	4116	+ FCB $C5
	4117	+ FDB IDDOT-6
	4118	+CREATE FDB DOCOL,DFIND,ZBRAN
	4119	+ FDB CREAT2-*-NATWID
	4120	+ FDB DROP,PDOTQ
	4121	+ FCB 8
	4122	+ FCB 7 ( bel )
	4123	+ FCC "redef: "
	4124	+ FDB NFA,IDDOT,LIT8
	4125	+ FCB 4
	4126	+ FDB MESS,SPACE
	4127	+CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
	4128	+ FDB ONEP,ALLOT,DUP,LIT8
	4129	+ FCB ($80\|FSMUDG) ; Bracket the name.
	4130	+ FDB TOGGLE,HERE,ONE,SUB,LIT8
	4131	+ FCB $80
	4132	+ FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
	4133	+* FDB HERE,TWOP,COMMA
	4134	+ FDB HERE,NATP,COMMA
	4135	+ FDB SEMIS
	4136	+*
	4137	+* ######>> screen 52 <<
	4138	+* ======>> 146 <<
	4139	+* ( --- ) P
	4140	+* { [COMPILE] name } typical use
	4141	+* -DFIND next WORD and COMPILE it, literally;
	4142	+* used to compile immediate definitions into words.
	4143	+ FCB $C9 immediate
	4144	+ FCC '[COMPILE' ; '[COMPILE]'
	4145	+ FCB $DD
	4146	+ FDB CREATE-9
	4147	+BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
	4148	+ FDB SEMIS
	4149	+*
	4150	+* ======>> 147 <<
	4151	+* ( n --- ) if compiling. P
	4152	+* ( n --- n ) if interpreting.
	4153	+* Compile n as a literal, if compiling.
	4154	+ FCB $C7 immediate
	4155	+ FCC 'LITERA' ; 'LITERAL'
	4156	+ FCB $CC
	4157	+ FDB BCOMP-12
	4158	+LITER FDB DOCOL,STATE,AT,ZBRAN
	4159	+ FDB LITER2-*-NATWID
	4160	+ FDB COMPIL,LIT,COMMA
	4161	+LITER2 FDB SEMIS
	4162	+*
	4163	+* ======>> 148 <<
	4164	+* ( d --- ) if compiling. P
	4165	+* ( d --- d ) if interpreting.
	4166	+* Compile d as a double literal, if compiling.
	4167	+ FCB $C8 immediate
	4168	+ FCC 'DLITERA' ; 'DLITERAL'
	4169	+ FCB $CC
	4170	+ FDB LITER-10
	4171	+DLITER FDB DOCOL,STATE,AT,ZBRAN
	4172	+ FDB DLITE2-*-NATWID
	4173	+ FDB SWAP,LITER,LITER ; Just two literals in the right order.
	4174	+DLITE2 FDB SEMIS
	4175	+*
	4176	+* ######>> screen 53 <<
	4177	+* ======>> 149 <<
	4178	+* ( --- )
	4179	+* Interpret or compile, according to STATE.
	4180	+* Searches words parsed in dictionary first, via -FIND,
	4181	+* then checks for valid NUMBER.
	4182	+* Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
	4183	+* ERROR checks the stack via ?STACK before returning to its caller.
	4184	+ FCB $89
	4185	+ FCC 'INTERPRE' ; 'INTERPRET'
	4186	+ FCB $D4
	4187	+ FDB DLITER-11
	4188	+INTERP FDB DOCOL
	4189	+INTER2 FDB DFIND,ZBRAN
	4190	+ FDB INTER5-*-NATWID
	4191	+ FDB STATE,AT,LESS
	4192	+ FDB ZBRAN
	4193	+ FDB INTER3-*-NATWID
	4194	+ FDB CFA,COMMA,BRAN
	4195	+ FDB INTER4-*-NATWID
	4196	+INTER3 FDB CFA,EXEC
	4197	+INTER4 FDB BRAN
	4198	+ FDB INTER7-*-NATWID
	4199	+INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
	4200	+ FDB INTER6-*-NATWID
	4201	+ FDB DLITER,BRAN
	4202	+ FDB INTER7-*-NATWID
	4203	+INTER6 FDB DROP,LITER
	4204	+INTER7 FDB QSTACK,BRAN
	4205	+ FDB INTER2-*-NATWID
	4206	+* FDB SEMIS never executed
	4207	+
	4208	+*
	4209	+* ######>> screen 54 <<
	4210	+* ======>> 150 <<
	4211	+* ( --- )
	4212	+* Toggle precedence bit of LATEST definition header.
	4213	+* During compiling, most symbols scanned are compiled.
	4214	+* IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
	4215	+* but may be compiled via ' (TICK).
	4216	+ FCB $89
	4217	+ FCC 'IMMEDIAT' ; 'IMMEDIATE'
	4218	+ FCB $C5
	4219	+ FDB INTERP-12
	4220	+IMMED FDB DOCOL,LATEST,LIT8
	4221	+ FCB FIMMED
	4222	+ FDB TOGGLE
	4223	+ FDB SEMIS
	4224	+*
	4225	+* ======>> 151 <<
	4226	+* ( --- ) { VOCABULARY name } input
	4227	+* Create a vocabulary entry with a flag for terminating vocabulary searches.
	4228	+* Store the current search context in it for linking.
	4229	+* At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
	4230	+ FCB $8A
	4231	+ FCC 'VOCABULAR' ; 'VOCABULARY'
	4232	+ FCB $D9
	4233	+ FDB IMMED-12
	4234	+VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
	4235	+ FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
	4236	+* DOVOC FDB TWOP,CONTXT,STORE
	4237	+DOVOC FDB NATP,CONTXT,STORE
	4238	+ FDB SEMIS
	4239	+*
	4240	+* ======>> 152 <<
	4241	+*
	4242	+* Note: FORTH does not go here in the rom-able dictionary,
	4243	+* since FORTH is a type of variable.
	4244	+*
	4245	+* (Should make a proper architecture for this at some point.)
	4246	+*
	4247	+*
	4248	+* ======>> 153 <<
	4249	+* ( --- )
	4250	+* Makes the current interpretation CONTEXT vocabulary
	4251	+* also the CURRENT defining vocabulary.
	4252	+ FCB $8B
	4253	+ FCC 'DEFINITION' ; 'DEFINITIONS'
	4254	+ FCB $D3
	4255	+ FDB VOCAB-13
	4256	+DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
	4257	+ FDB SEMIS
	4258	+*
	4259	+* ======>> 154 <<
	4260	+* ( --- )
	4261	+* Parse out a comment and toss it away.
	4262	+* Leaves the leading characters in WORDPAD, which may or may not be useful.
	4263	+ FCB $C1 immediate (
	4264	+ FCB $A8
	4265	+ FDB DEFIN-14
	4266	+PAREN FDB DOCOL,LIT8
	4267	+ FCC ")"
	4268	+ FDB WORD
	4269	+ FDB SEMIS
	4270	+*
	4271	+* ######>> screen 55 <<
	4272	+* ======>> 155 <<
	4273	+* ( anything *** nothing )
	4274	+* Clear return stack.
	4275	+* Then INTERPRET and, if not compiling, prompt with OK,
	4276	+* in infinite loop.
	4277	+ FCB $84
	4278	+ FCC 'QUI' ; 'QUIT'
	4279	+ FCB $D4
	4280	+ FDB PAREN-4
	4281	+QUIT FDB DOCOL,ZERO,BLK,STORE
	4282	+ FDB LBRAK
	4283	+*
	4284	+* Here is the outer interpretter
	4285	+* which gets a line of input, does it, prints " OK"
	4286	+* then repeats :
	4287	+QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
	4288	+ FDB ZBRAN
	4289	+ FDB QUIT3-*-NATWID
	4290	+ FDB PDOTQ
	4291	+ FCB 3
	4292	+ FCC ' OK' ; ' OK'
	4293	+QUIT3 FDB BRAN
	4294	+ FDB QUIT2-*-NATWID
	4295	+* FDB SEMIS ( never executed )
	4296	+*
	4297	+* ======>> 156 <<
	4298	+* ( anything --- nothing ) ( anything *** nothing )
	4299	+* Clear parameter stack,
	4300	+* set STATE to interpret and BASE to DECIMAL,
	4301	+* return to input from terminal,
	4302	+* restore DRIVE OFFSET to 0,
	4303	+* print out "Forth-68",
	4304	+* set interpret and define vocabularies to FORTH,
	4305	+* and finally, QUIT.
	4306	+* Used to force the system to a known state
	4307	+* and return control to the initial INTERPRETer.
	4308	+ FCB $85
	4309	+ FCC 'ABOR' ; 'ABORT'
	4310	+ FCB $D4
	4311	+ FDB QUIT-7
	4312	+ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
	4313	+ FCB 14
	4314	+ FCC "fig-Forth-6809"
	4315	+ FDB FORTH,DEFIN
	4316	+ FDB QUIT
	4317	+* FDB SEMIS never executed
	4318	+ PAGE
	4319	+*
	4320	+* ######>> screen 56 <<
	4321	+* bootstrap code... moves rom contents to ram :
	4322	+* ======>> 157 <<
	4323	+ FCB $84
	4324	+ FCC 'COL' ; 'COLD'
	4325	+ FCB $C4
	4326	+ FDB ABORT-8
	4327	+COLD FDB *+NATWID
	4328	+* Ultimately, we want position indepence,
	4329	+* so I'm using PCR where it seems reasonable.
	4330	+CENT LDS RINIT,PCR ; Get a useable return stack, at least.
	4331	+ LDU SINIT,PCR ; Get a useable parameter stack, too.
	4332	+ LDA #IUPDP ; This is not relative to PC.
	4333	+ TFR A,DP ; And a useable direct page, too.
	4334	+ SETDP IUPDP ; (For good measure.)
	4335	+*
	4336	+* CLR TRACEM ; DBG
	4337	+* DEC TRACEM ; DBG
	4338	+* LBSR DBGREG
	4339	+* We'll keep this here for the time being.
	4340	+* There are better ways to do this, of course.
	4341	+* Re-architect, re-architect.
	4342	+ LEAX ERAM,PCR ; end of stuff to move
	4343	+ STX <XFENCE ; Borrow this variable for a loop terminator.
	4344	+ LDY #RBEG ; bottom of open-ended destination
	4345	+ LEAX RAM,PCR ; bottom of stuff to move
	4346	+COLD2 LDA ,X+
	4347	+ STA ,Y+ ; move TASK & FORTH to ram
	4348	+* LBSR DBGREG
	4349	+ CMPX <XFENCE
	4350	+ BNE COLD2
	4351	+* Leaves USE and PREV uninitialized.
	4352	+ LDX BUFINT,PCR
	4353	+ STX <XUSE
	4354	+ STX <XPREV
	4355	+* LEAX RAM,PCR
	4356	+* STX <XFENCE ; Borrow this variable for a loop terminator.
	4357	+* LEAY REND,PCR ; top of destination (included XUSE and XPREV)
	4358	+* LEAX ERAM,PCR ; top of stuff to move (included initializers for XUSE and XPREV)
	4359	+* COLD2 LDA ,-X
	4360	+* STA ,-Y ; move TASK & FORTH to ram
	4361	+* CMPX <XFENCE
	4362	+* BNE COLD2
	4363	+*
	4364	+* CENT LDS #REND-1 top of destination
	4365	+* LDX #ERAM top of stuff to move
	4366	+* COLD2 LEAX -1,X ;
	4367	+* LDA 0,X
	4368	+* PSHS A ; move TASK & FORTH to ram
	4369	+* CMPX #RAM
	4370	+* BNE COLD2
	4371	+*
	4372	+* LDS #XFENCE-1 put stack at a safe place for now
	4373	+* But that is taken care of.
	4374	+* LDX COLINT
	4375	+* STX XCOLUM
	4376	+ LDX COLINT,PCR
	4377	+ STX <XCOLUM
	4378	+* LDX DELINT
	4379	+* STX XDELAY
	4380	+ LDX DELINT,PCR
	4381	+ STX <XDELAY
	4382	+* LDX VOCINT
	4383	+* STX XVOCL
	4384	+ LDX VOCINT,PCR
	4385	+ STX <XVOCL
	4386	+* LDX DPINIT
	4387	+* STX XDICTP
	4388	+ LDX DPINIT,PCR
	4389	+ STX <XDICTP
	4390	+* LDX FENCIN
	4391	+* STX XFENCE
	4392	+ LDX FENCIN,PCR
	4393	+ STX <XFENCE
	4394	+*
	4395	+WENT LDS SINIT,PCR ; Get a useable return stack, at least.
	4396	+ LDA #IUPDP ; This is not relative to PC.
	4397	+ TFR A,DP ; And a useable direct page, too.
	4398	+ SETDP IUPDP ; (For good measure.)
	4399	+*
	4400	+ LEAX SINIT,PCR
	4401	+ PSHS X ; for loop termination
	4402	+ CLRB ; Yes, I'm being a little ridiculous. Only a little.
	4403	+ TFR D,Y
	4404	+ LEAY XFENCE-UORIG,Y ; top of destination
	4405	+ LEAX FENCIN,PCR ; top of stuff to move
	4406	+WARM2 LDD ,--X ; All entries are 16 bit.
	4407	+ STD ,--Y
	4408	+* LBSR DBGREG
	4409	+ CMPX ,S
	4410	+ BNE WARM2
	4411	+ LEAS 2,S ; But we'll reset the return stack shortly, anyway.
	4412	+ LDU <XSPZER ; So we can clear the hole above the TOS
	4413	+* WENT LDS #XFENCE-1 top of destination
	4414	+* LDX #FENCIN top of stuff to move
	4415	+* WARM2 LEAX -1,X ;
	4416	+* LDA 0,X
	4417	+* PSHS A ;
	4418	+* CMPX #SINIT
	4419	+* BNE WARM2
	4420	+*
	4421	+* LDS SINIT
	4422	+* S is already there.
	4423	+* LDX UPINIT
	4424	+* STX UP init user ram pointer
	4425	+* UP is already there (DP).
	4426	+* LDX #ABORT
	4427	+* STX IP
	4428	+ LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
	4429	+*
	4430	+ NOP Here is a place to jump to special user
	4431	+ NOP initializations such as I/0 interrups
	4432	+ NOP
	4433	+*
	4434	+* For systems with TRACE:
	4435	+ LDX #00
	4436	+ STX ,U The hole above the parameter stack
	4437	+* STX TRLIM clear trace mode
	4438	+ STX <TRLIM clear trace mode (both bytes)
	4439	+ LDX #0
	4440	+* STX BRKPT clear breakpoint address
	4441	+ STX <BRKPT ; clear breakpoint address
	4442	+* JMP RPSTOR+2 start the virtual machine running !
	4443	+ JMP [RPSTOR,PCR] ; start the virtual machine running !
	4444	+* RPSTOR's NEXT will pick up the IP in Y, set above, and start ABORT.
	4445	+* LBSR RPSTOR+NATWID ; start the virtual machine running !
	4446	+* LEAX WENT,PCR ; But we must also give RP! someplace to return.
	4447	+* STX ,S ; This rail might get walked on by (DO).
	4448	+* LBRA NEXT
	4449	+* RP! sets up the return stack pointer, then Y references abort.
	4450	+*
	4451	+* Here is the stuff that gets copied to ram :
	4452	+* (not * at address $140:)
	4453	+* at an appropriate address:
	4454	+*
	4455	+* RAM FDB $3000,$3000,0,0
	4456	+* RAM FDB BUFBAS,BUFBAS,0,0 ; ... except the direct page has moved.
	4457	+* These initialization values for USE and PREV were here to help pack the code.
	4458	+* They don't belong here unless we move the USER table
	4459	+* back below the writable dictionary,
	4460	+* and move these USER variables to the end of the direct page --
	4461	+* or let these definitions exist in the USER table.
	4462	+RAM EQU *
	4463	+
	4464	+* ======>> (152) <<
	4465	+* ( --- ) P
	4466	+* Makes FORTH the current interpretation vocabulary.
	4467	+* In order to make this ROMmable, this entry is set up as the tail-end,
	4468	+* and copied to RAM in the start-up code.
	4469	+* We want a more elegant solution to this, too. Greedy, maybe.
	4470	+ FCB $C5 immediate
	4471	+ FCC 'FORT' ; 'FORTH'
	4472	+ FCB $C8
	4473	+ FDB NOOP-7 ; Note that this does not link to COLD!
	4474	+RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
	4475	+ FDB 0
	4476	+ FCC "Copyright 1979 Forth Interest Group, David Lion,"
	4477	+ FCB $0D
	4478	+ FCC "Parts Copyright 2019 Joel Matthew Rees"
	4479	+ FCB $0D
	4480	+ FCB $84
	4481	+ FCC 'TAS' ; 'TASK'
	4482	+ FCB $CB
	4483	+ FDB FORTH-8
	4484	+RTASK FDB DOCOL,SEMIS
	4485	+ERAM EQU *
	4486	+ERAMSZ EQU *-RAM ; So we can get a look at it.
	4487	+ PAGE
	4488	+*
	4489	+* ######>> screen 57 <<
	4490	+* ======>> 158 <<
	4491	+* ( n0 --- d0 )
	4492	+* Sign extend n0 to a double integer.
	4493	+ FCB $84
	4494	+ FCC 'S->' ; 'S->D'
	4495	+ FCB $C4
	4496	+ FDB COLD-7 ; Note that this does not link to FORTH (RFORTH)!
	4497	+STOD FDB DOCOL,DUP,ZLESS,MINUS
	4498	+ FDB SEMIS
	4499	+
	4500	+
	4501	+*
	4502	+* ======>> 159 <<
	4503	+* ( multiplier multiplicand --- product )
	4504	+* Signed word multiply.
	4505	+ FCB $81 ; *
	4506	+ FCB $AA
	4507	+ FDB STOD-7
	4508	+STAR FDB DOCOL
	4509	+ FDB USTAR,DROP,SEMIS ; Drop high word.
	4510	+* STAR FDB *+NATWID
	4511	+* LBSR USTAR+NATWID ; or [USTAR,PCR]?
	4512	+* LEAU NATWID,U ; Drop high word. Seems like magic, doesn't it?
	4513	+* LBRA NEXT
	4514	+* JSR USTARS
	4515	+* LEAS 1,S ;
	4516	+* LEAS 1,S ;
	4517	+* JMP NEXT
	4518	+*
	4519	+* ======>> 160 <<
	4520	+* ( dividend divisor --- remainder quotient )
	4521	+* M/ in word-only form, i. e., signed division of 2nd word by top word,
	4522	+* yielding signed word quotient and remainder.
	4523	+* Except BUG it isn't signed.
	4524	+ FCB $84
	4525	+ FCC '/MO' ; '/MOD'
	4526	+ FCB $C4
	4527	+ FDB STAR-4
	4528	+SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
	4529	+ FDB SEMIS
	4530	+*
	4531	+* ======>> 161 <<
	4532	+* ( dividend divisor --- quotient )
	4533	+* Signed word divide without remainder.
	4534	+* Except BUG it isn't signed.
	4535	+ FCB $81 ; /
	4536	+ FCB $AF
	4537	+ FDB SLMOD-7
	4538	+SLASH FDB DOCOL,SLMOD,SWAP,DROP
	4539	+ FDB SEMIS
	4540	+*
	4541	+* ======>> 162 <<
	4542	+* ( dividend divisor --- remainder )
	4543	+* Remainder function, result takes sign of dividend.
	4544	+ FCB $83
	4545	+ FCC 'MO' ; 'MOD'
	4546	+ FCB $C4
	4547	+ FDB SLASH-4
	4548	+MOD FDB DOCOL,SLMOD,DROP
	4549	+ FDB SEMIS
	4550	+*
	4551	+* ======>> 163 <<
	4552	+* ( multiplier multiplicand divisor --- remainder quotient )
	4553	+* Signed precise division of product:
	4554	+* multiply 2nd and 3rd words on stack
	4555	+* and divide the 31-bit product by the top word,
	4556	+* leaving both quotient and remainder.
	4557	+* Remainder takes sign of product.
	4558	+* Guaranteed not to lose significant bits in 16 bit integer math.
	4559	+ FCB $85
	4560	+ FCC '/MO' ; '/MOD'
	4561	+ FCB $C4
	4562	+ FDB MOD-6
	4563	+SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
	4564	+ FDB SEMIS
	4565	+*
	4566	+* ======>> 164 <<
	4567	+* ( multiplier multiplicand divisor --- quotient )
	4568	+* */MOD without remainder.
	4569	+ FCB $82
	4570	+ FCC '' ; '/'
	4571	+ FCB $AF
	4572	+ FDB SSMOD-8
	4573	+SSLASH FDB DOCOL,SSMOD,SWAP,DROP
	4574	+ FDB SEMIS
	4575	+*
	4576	+* ======>> 165 <<
	4577	+* ( ud1 u1 --- u2 ud2 )
	4578	+* U/ with an (unsigned) double quotient.
	4579	+* Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
	4580	+* if you are prepared to deal with the extra 16 bits of result.
	4581	+ FCB $85
	4582	+ FCC 'M/MO' ; 'M/MOD'
	4583	+ FCB $C4
	4584	+ FDB SSLASH-5
	4585	+MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
	4586	+ FDB FROMR,SWAP,TOR,USLASH,FROMR
	4587	+ FDB SEMIS
	4588	+*
	4589	+* ======>> 166 <<
	4590	+* ( n>=0 --- n )
	4591	+* ( n<0 --- -n )
	4592	+* Convert the top of stack to its absolute value.
	4593	+ FCB $83
	4594	+ FCC 'AB' ; 'ABS'
	4595	+ FCB $D3
	4596	+ FDB MSMOD-8
	4597	+ABS FDB DOCOL,DUP,ZLESS,ZBRAN
	4598	+ FDB ABS2-*-NATWID
	4599	+ FDB MINUS
	4600	+ABS2 FDB SEMIS
	4601	+*
	4602	+* ======>> 167 <<
	4603	+* ( d>=0 --- d )
	4604	+* ( d<0 --- -d )
	4605	+* Convert the top double to its absolute value.
	4606	+ FCB $84
	4607	+ FCC 'DAB' ; 'DABS'
	4608	+ FCB $D3
	4609	+ FDB ABS-6
	4610	+DABS FDB DOCOL,DUP,ZLESS,ZBRAN
	4611	+ FDB DABS2-*-NATWID
	4612	+ FDB DMINUS
	4613	+DABS2 FDB SEMIS
	4614	+*
	4615	+* ######>> screen 58 <<
	4616	+* Disc primitives :
	4617	+* ======>> 168 <<
	4618	+* ( --- vadr )
	4619	+* Least Recently Used buffer.
	4620	+* Really should be with FIRST and LIMIT in the per-task table.
	4621	+ FCB $83
	4622	+ FCC 'US' ; 'USE'
	4623	+ FCB $C5
	4624	+ FDB DABS-7
	4625	+USE FDB DOCON
	4626	+ FDB XUSE
	4627	+* ======>> 169 <<
	4628	+* ( --- vadr )
	4629	+* Most Recently Used buffer.
	4630	+* Really should be with FIRST and LIMIT in the per-task table.
	4631	+ FCB $84
	4632	+ FCC 'PRE' ; 'PREV'
	4633	+ FCB $D6
	4634	+ FDB USE-6
	4635	+PREV FDB DOCON
	4636	+ FDB XPREV
	4637	+* ======>> 170 <<
	4638	+* ( buffer1 --- buffer2 f )
	4639	+* Bump to next buffer,
	4640	+* flag false if result is PREVious buffer,
	4641	+* otherwise flag true.
	4642	+* Used in the LRU allocation routines.
	4643	+ FCB $84
	4644	+ FCC '+BU' ; '+BUF'
	4645	+ FCB $C6
	4646	+ FDB PREV-7
	4647	+* PBUF FDB DOCOL,LIT8
	4648	+* FCB $84 ; This was a hard-wiring bug.
	4649	+PBUF FDB DOCOL,BBUF,BCTL,PLUS ; Size of the buffer record.
	4650	+* FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
	4651	+ FDB PLUS,DUP,LIMIT,LESS,ZEQU,OVER,FIRST,LESS,OR,ZBRAN
	4652	+ FDB PBUF2-*-NATWID ; Use defensive programming.
	4653	+ FDB DROP,FIRST
	4654	+PBUF2 FDB DUP,PREV,AT,SUB
	4655	+ FDB SEMIS
	4656	+*
	4657	+* ======>> 171 <<
	4658	+* ( --- f )
	4659	+* Flag to mark a buffer dirty, in need of being written out.
	4660	+* This flag limits the max number of sectors in a disk to ((256^NATWID)/2)-1.
	4661	+* It also hard-codes an implicit test which is used elsewhere.
	4662	+ FCB $8A
	4663	+ FCC 'UPDATE-BI' ; 'UPDATE-BIT'
	4664	+ FCB $D4
	4665	+ FDB PBUF-7
	4666	+UPDBIT FDB DOCON
	4667	+ FDB $8000
	4668	+*
	4669	+* ( --- )
	4670	+* Mark PREVious buffer dirty, in need of being written out.
	4671	+ FCB $86
	4672	+ FCC 'UPDAT' ; 'UPDATE'
	4673	+ FCB $C5
	4674	+ FDB UPDBIT-13
	4675	+* UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
	4676	+UPDATE FDB DOCOL,PREV,AT,AT,UPDBIT,OR,PREV,AT,STORE
	4677	+ FDB SEMIS
	4678	+*
	4679	+* ======>> 172 <<
	4680	+* ( adr --- )
	4681	+* Mark the buffer addressed as empty.
	4682	+* Have to add code to avoid block 0 appearing to be in a buffer from COLD.
	4683	+* Usually, there is no sector 0 (?), but the RAM buffers are too simple.
	4684	+* Note that without this block number being made illegal,
	4685	+* about 8 binaryMegabytes (256 bytes/block) of disk can be addressed total.
	4686	+* With this block number made illegal, the max is 1 block less,
	4687	+* still about 8 biMeg.
	4688	+ FCB $8B
	4689	+ FCC 'KILL-BUFFE' ; 'KILL-BUFFER'
	4690	+ FCB $D2
	4691	+ FDB UPDATE-9
	4692	+KILBUF FDB *+NATWID ; DOCOL,UPDBIT,ONE,SUB,SWAP,STORE
	4693	+ PULU X
	4694	+ LDD UPDBIT+NATWID,PCR
	4695	+ SUBD #1
	4696	+ STD ,X
	4697	+* LBSR DBGREG
	4698	+ LBRA NEXT
	4699	+*
	4700	+* ( --- )
	4701	+* Mark all buffers empty.
	4702	+ FCB $8C
	4703	+ FCC 'KILL-BUFFER' ; 'KILL-BUFFERS'
	4704	+ FCB $D3
	4705	+ FDB KILBUF-14
	4706	+KLBFS FDB DOCOL,FIRST,LIT8
	4707	+ FCB 4 ; Want to make sure it's only four.
	4708	+ FDB ZERO,XDO ; It would be "cleaner" to let +BUF control the loop.
	4709	+ FDB DUP,KILBUF,PBUF,DROP,XLOOP
	4710	+ FDB DROP,SEMIS
	4711	+* KLBFS FDB *+NATWID
	4712	+* LDD #4
	4713	+* PSHU D
	4714	+* LDD FIRST+NATWID,PCR
	4715	+* INC <TRACEM
	4716	+* LBSR DBGREG
	4717	+* PSHU D ; DUP
	4718	+* KLBFSL PSHU D
	4719	+* BSR KILBUF+NATWID
	4720	+* LDD ,U
	4721	+* LBSR DBGREG
	4722	+* ADDD BBUF+NATWID,PCR
	4723	+* ADDD BCTL+NATWID,PCR
	4724	+* STD ,U
	4725	+* LBSR DBGREG
	4726	+* DEC NATWID+1,U
	4727	+* BNE KLBFSL
	4728	+* LBSR DBGREG
	4729	+* LEAU NATWID*2,U
	4730	+* DEC <TRACEM
	4731	+* LBRA NEXT
	4732	+*
	4733	+* ( --- )
	4734	+* Erase and mark all buffers empty.
	4735	+* Standard method of discarding changes.
	4736	+ FCB $8D
	4737	+ FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
	4738	+ FCB $D3
	4739	+ FDB KLBFS-15
	4740	+MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
	4741	+* FDB FIRST,DUP,KILBUF,PBUF,DROP,DUP,KILBUF
	4742	+* FDB PBUF,DROP,DUP,KILBUF,PBUF,DROP,KILBUF
	4743	+ FDB KLBFS
	4744	+ FDB SEMIS
	4745	+*
	4746	+* ======>> 173 <<
	4747	+* ( --- )
	4748	+* Clear the current offset to the block numbers in the drive interface.
	4749	+* The drives need to be re-architected.
	4750	+* Would be cool to have RAM and ROM drives supported
	4751	+* in addition to regular physical persistent store.
	4752	+ FCB $83
	4753	+ FCC 'DR' ; 'DR0'
	4754	+ FCB $B0
	4755	+ FDB MTBUF-16
	4756	+DRZERO FDB DOCOL,ZERO,OFSET,STORE
	4757	+ FDB SEMIS
	4758	+*
	4759	+* ======>> 174 <<== system dependant word
	4760	+* ( --- )
	4761	+* Set the current offset in the drive interface to reference the second drive.
	4762	+* The hard-coded number in there needs to be in a table.
	4763	+ FCB $83
	4764	+ FCC 'DR' ; 'DR1'
	4765	+ FCB $B1
	4766	+ FDB DRZERO-6
	4767	+DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
	4768	+; **** hard-codes the size of the disc !!!!
	4769	+ FDB SEMIS
	4770	+*
	4771	+* ######>> screen 59 <<
	4772	+* ======>> 175 <<
	4773	+* ( n --- buffer )
	4774	+* Get a free buffer,
	4775	+* assign it to block n,
	4776	+* return buffer address.
	4777	+* Will free a buffer by writing it, if necessary.
	4778	+* Does not actually read the block.
	4779	+* A bug in the fig LRU algorithm, which I have not fixed,
	4780	+* gives the PREVious buffer if USE gets set to PREVious.
	4781	+* (The bug is that USE sometimes gets set to PREVious.)
	4782	+* This bug sometimes causes sector moves to become sector fills.
	4783	+ FCB $86
	4784	+ FCC 'BUFFE' ; 'BUFFER'
	4785	+ FCB $D2
	4786	+ FDB DRONE-6
	4787	+BUFFER FDB DOCOL,USE,AT,DUP,TOR
	4788	+BUFFR2 FDB PBUF,ZBRAN
	4789	+ FDB BUFFR2-*-NATWID
	4790	+ FDB USE,STORE,R,AT,ZLESS
	4791	+ FDB ZBRAN
	4792	+ FDB BUFFR3-*-NATWID
	4793	+* FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
	4794	+ FDB R,NATP,R,AT,UPDBIT,LNOT,AND,ZERO,RW
	4795	+* BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
	4796	+BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
	4797	+ FDB SEMIS
	4798	+*
	4799	+* ######>> screen 60 <<
	4800	+* ======>> 176 <<
	4801	+* ( n --- buffer )
	4802	+* Get BUFFER containing block n, relative to OFFSET.
	4803	+* If block n is not in a buffer, bring it in.
	4804	+* Returns buffer address.
	4805	+ FCB $85
	4806	+ FCC 'BLOC' ; 'BLOCK'
	4807	+ FCB $CB
	4808	+ FDB BUFFER-9
	4809	+BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
	4810	+ FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
	4811	+ FDB BLOCK5-*-NATWID
	4812	+BLOCK3 FDB PBUF,ZEQU,ZBRAN
	4813	+ FDB BLOCK4-*-NATWID
	4814	+* FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
	4815	+ FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
	4816	+BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
	4817	+ FDB BLOCK3-*-NATWID
	4818	+ FDB DUP,PREV,STORE
	4819	+* BLOCK5 FDB FROMR,DROP,TWOP
	4820	+BLOCK5 FDB FROMR,DROP,NATP
	4821	+ FDB SEMIS
	4822	+*
	4823	+* ######>> screen 61 <<
	4824	+* ======>> 177 <<
	4825	+* ( line screen --- buffer C/L)
	4826	+* Bring in the sector containing the specified line of the specified screen.
	4827	+* Returns the buffer address and the width of the screen.
	4828	+* Screen number is relative to OFFSET.
	4829	+* The line number may be beyond screen 4,
	4830	+* (LINE) will get the appropriate screen.
	4831	+ FCB $86
	4832	+ FCC '(LINE' ; '(LINE)'
	4833	+ FCB $A9
	4834	+ FDB BLOCK-8
	4835	+PLINE FDB DOCOL,TOR,LIT8
	4836	+ FCB $40
	4837	+ FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
	4838	+ FCB $40
	4839	+ FDB SEMIS
	4840	+*
	4841	+* ======>> 178 <<
	4842	+* ( line screen --- )
	4843	+* Print the line of the screen as found by (LINE), suppress trailing BLANKS.
	4844	+ FCB $85
	4845	+ FCC '.LIN' ; '.LINE'
	4846	+ FCB $C5
	4847	+ FDB PLINE-9
	4848	+DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
	4849	+ FDB SEMIS
	4850	+*
	4851	+* ======>> 179 <<
	4852	+* ( n --- )
	4853	+* If WARNING is 0, print "MESSAGE #n";
	4854	+* otherwise, print line n relative to screen 4,
	4855	+* the line number may be negative.
	4856	+* Uses .LINE, but counter-adjusts to be relative to the real drive 0.
	4857	+ FCB $87
	4858	+ FCC 'MESSAG' ; 'MESSAGE'
	4859	+ FCB $C5
	4860	+ FDB DLINE-8
	4861	+MESS FDB DOCOL,WARN,AT,ZBRAN
	4862	+ FDB MESS3-*-NATWID
	4863	+ FDB DDUP,ZBRAN
	4864	+ FDB MESS3-*-NATWID
	4865	+ FDB LIT8
	4866	+ FCB 4
	4867	+ FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
	4868	+ FDB MESS4-*-NATWID
	4869	+MESS3 FDB PDOTQ
	4870	+ FCB 6
	4871	+ FCC 'err # ' ; 'err # '
	4872	+ FDB DOT
	4873	+MESS4 FDB SEMIS
	4874	+*
	4875	+* ======>> 180 <<
	4876	+* ( n --- )
	4877	+* Begin interpretation of screen (block) n.
	4878	+* See also ARROW, SEMIS, and NULL.
	4879	+ FCB $84
	4880	+ FCC 'LOA' ; 'LOAD' : input:scr #
	4881	+ FCB $C4
	4882	+ FDB MESS-10
	4883	+LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
	4884	+ FDB BSCR,STAR,BLK,STORE
	4885	+ FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
	4886	+ FDB SEMIS
	4887	+*
	4888	+* ======>> 181 <<
	4889	+* ( --- ) P
	4890	+* Continue interpreting source code on the next screen.
	4891	+ FCB $C3
	4892	+ FCC '--' ; '-->'
	4893	+ FCB $BE
	4894	+ FDB LOAD-7
	4895	+ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
	4896	+ FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
	4897	+ FDB SEMIS
	4898	+ PAGE
	4899	+*
	4900	+*
	4901	+* ######>> screen 63 <<
	4902	+* The next 4 subroutines are machine dependent, and are
	4903	+* called by words 13 through 16 in the dictionary.
	4904	+*
	4905	+* ======>> 182 << code for EMIT
	4906	+* ( --- ) No parameter stack effect.
	4907	+* Interfaces directly with ROM. Expects output character in D (therefore, B).
	4908	+* Output using rom CHROUT: redirectable to a printer on Coco.
	4909	+* Outputs the character on stack (low byte of 1 bit word/cell).
	4910	+PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.)
	4911	+ TFR B,A ; Coco ROM wants it in A.
	4912	+ CLRB
	4913	+ TFR B,DP ; Give the ROM its direct page.
	4914	+ JSR [$A002] ; Output the character in A.
	4915	+ PULS Y,U,DP,PC
	4916	+* PEMIT STB N save B
	4917	+* STX N+1 save X
	4918	+* LDB ACIAC
	4919	+* BITB #2 check ready bit
	4920	+* BEQ PEMIT+4 if not ready for more data
	4921	+* STA ACIAD
	4922	+* LDX UP
	4923	+* STB IOSTAT-UORIG,X
	4924	+* LDB N recover B & X
	4925	+* LDX N+1
	4926	+* RTS only A register may change
	4927	+* PEMIT JMP $E1D1 for MIKBUG
	4928	+* PEMIT FCB $3F,$11,$39 for PROTO
	4929	+* PEMIT JMP $D286 for Smoke Signal DOS
	4930	+*
	4931	+* ======>> 183 << code for KEY
	4932	+* ( --- ) No parameter stack effect.
	4933	+* Returns character or break flag in D, since this interfaces with Coco ROM.
	4934	+* Wait for key from POLCAT on Coco.
	4935	+* Returns the character code for the key pressed.
	4936	+PKEY PSHS Y,U,DP ; Must save everything important for this one.
	4937	+ LDA #$CF ; a cursor of sorts
	4938	+ CLRB
	4939	+ TFR B,DP
	4940	+ SETDP 0
	4941	+ LDX <$88 ; location
	4942	+ LDB ,X ; save glyph
	4943	+ STA ,X
	4944	+PKEYLP JSR [$A000]
	4945	+* STA $41A ; DBG!
	4946	+ BEQ PKEYLP
	4947	+* STD $418 ; DBG!
	4948	+ STB ,X ; restore
	4949	+PKEYR CLRB ; for the break flag, shares code with PQTER
	4950	+ CMPA #3 ; break key
	4951	+ BNE PKEYGT
	4952	+ COMB ; for the break flag
	4953	+PKEYGT EXG A,B ; Leave it in D for return.
	4954	+ PULS Y,U,DP,PC ; Shares exit with PQTER
	4955	+ SETDP IUPDP
	4956	+* PKEY STB N
	4957	+* STX N+1
	4958	+* LDB ACIAC
	4959	+* ASRB ;
	4960	+* BCC PKEY+4 no incoming data yet
	4961	+* LDA ACIAD
	4962	+* ANDA #$7F strip parity bit
	4963	+* LDX UP
	4964	+* STB IOSTAT+1-UORIG,X
	4965	+* LDB N
	4966	+* LDX N+1
	4967	+* RTS
	4968	+* PKEY JMP $E1AC for MIKBUG
	4969	+* PKEY FCB $3F,$14,$39 for PROTO
	4970	+* PKEY JMP $D289 for Smoke Signal DOS
	4971	+*
	4972	+* ######>> screen 64 <<
	4973	+* ======>> 184 << code for ?TERMINAL
	4974	+* ( --- f ) Should change this to no stack effect.
	4975	+* check break key using POLCAT
	4976	+* Returns a flag to tell whether the break key was pressed or not.
	4977	+PQTER PSHS Y,U,DP
	4978	+ CLRB
	4979	+ TFR B,DP
	4980	+ JSR [$A000] ; Look but don't wait.
	4981	+ BRA PKEYR
	4982	+* PQTER LDA ACIAC Test for 'break' condition
	4983	+* ANDA #$11 mask framing error bit and
	4984	+* input buffer full
	4985	+* BEQ PQTER2
	4986	+* LDA ACIAD clear input buffer
	4987	+* LDA #01
	4988	+* PQTER2 RTS
	4989	+
	4990	+
	4991	+ PAGE
	4992	+*
	4993	+* ======>> 185 << code for CR
	4994	+* ( --- ) No stack effect.
	4995	+* Interfaces directly with ROM.
	4996	+* For Coco just output a CR.
	4997	+* Also subject to redirection in Coco BASIC ROM.
	4998	+PCR LDB #$0D
	4999	+ BRA PEMIT ; Just steal the code.
	5000	+* PCR LDA #$D carriage return
	5001	+* BSR PEMIT
	5002	+* LDA #$A line feed
	5003	+* BSR PEMIT
	5004	+* LDA #$7F rubout
	5005	+* LDX UP
	5006	+* LDB XDELAY+1-UORIG,X
	5007	+* PCR2 DECB ;
	5008	+* BMI PQTER2 return if minus
	5009	+* PSHS B ; save counter
	5010	+* BSR PEMIT print RUBOUTs to delay.....
	5011	+* PULS B ;
	5012	+* BRA PCR2 repeat
	5013	+
	5014	+
	5015	+ PAGE
	5016	+*
	5017	+* ######>> screen 66 <<
	5018	+* ======>> 187 <<
	5019	+* ( ??? )
	5020	+* Query the disk, I suppose.
	5021	+* Not sure what the model had in mind for this stub.
	5022	+ FCB $85
	5023	+ FCC '?DIS' ; '?DISC'
	5024	+ FCB $C3
	5025	+ FDB ARROW-6
	5026	+QDISC FDB *+NATWID
	5027	+ JMP NEXT
	5028	+*
	5029	+* ######>> screen 67 <<
	5030	+* ======>> 189 <<
	5031	+* ( ??? )
	5032	+* Write one block of data to disk.
	5033	+* Parameters unspecified in model. Stub in model.
	5034	+ FCB $8B
	5035	+ FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
	5036	+ FCB $C5
	5037	+ FDB QDISC-8
	5038	+BWRITE FDB *+NATWID
	5039	+ JMP NEXT
	5040	+*
	5041	+* ######>> screen 68 <<
	5042	+* ======>> 190 <<
	5043	+* ( ??? )
	5044	+* Read one block of data from disk.
	5045	+* Parameters unspecified in model. Stub in model.
	5046	+ FCB $8A
	5047	+ FCC 'BLOCK-REA' ; 'BLOCK-READ'
	5048	+ FCB $C4
	5049	+ FDB BWRITE-14
	5050	+BREAD FDB *+NATWID
	5051	+ JMP NEXT
	5052	+*
	5053	+*The next 3 words are written to create a substitute for disc
	5054	+* mass memory,located between MASSLO & MASSHI in ram --
	5055	+* ($3210 and $3fff in the 6800 model).
	5056	+* ======>> 190.1 <<
	5057	+ FCB $82
	5058	+ FCC 'L' ; 'LO'
	5059	+ FCB $CF
	5060	+ FDB BREAD-13
	5061	+LO FDB DOCON
	5062	+ FDB MEMEND a system dependent equate at front
	5063	+*
	5064	+* ======>> 190.2 <<
	5065	+ FCB $82
	5066	+ FCC 'H' ; 'HI'
	5067	+ FCB $C9
	5068	+ FDB LO-5
	5069	+HI FDB DOCON
	5070	+ FDB MEMTOP ( $3FFF or $7FFF in this version )
	5071	+*
	5072	+* ######>> screen 69 <<
	5073	+* ======>> 191 <<
	5074	+* ( buffer sector f --- )
	5075	+* Read or Write the specified (absolute -- ignores OFFSET) sector
	5076	+* from or to the specified buffer.
	5077	+* A zero flag specifies write,
	5078	+* non-zero specifies read.
	5079	+* Sector is an unsigned integer,
	5080	+* buffer is the buffer's address.
	5081	+* Will need to use the CoCo ROM disk routines.
	5082	+* For now, provides a virtual disk in RAM.
	5083	+ FCB $83
	5084	+ FCC 'R/' ; 'R/W'
	5085	+ FCB $D7
	5086	+ FDB HI-5
	5087	+RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
	5088	+ FDB RW2-*-NATWID
	5089	+ FDB PDOTQ
	5090	+ FCB 8
	5091	+ FCC ' Range ?' ; ' Range ?'
	5092	+ FDB QUIT
	5093	+RW2 FDB FROMR,ZBRAN
	5094	+ FDB RW3-*-NATWID
	5095	+ FDB SWAP
	5096	+RW3 FDB BBUF,CMOVE
	5097	+ FDB SEMIS
	5098	+*
	5099	+* From BIF-6809:
	5100	+* RW PSHS Y,U,DP
	5101	+* LDY $C006 control table
	5102	+* LDX #DROFFS+7 ; This is BIF's table of drive sizes.
	5103	+* LDD 2,U
	5104	+* RWD SUBD ,X++ sectors
	5105	+* BHS RWD
	5106	+* BVC RWR table end?
	5107	+* LDD #6
	5108	+* PSHU D
	5109	+* JMP ERROR
	5110	+* RWR ADDD ,--X back one
	5111	+* PSHS X
	5112	+* PSHU D
	5113	+* LDD #18 sectors/track
	5114	+* PSHU D
	5115	+* DOCOL
	5116	+* FDB SLAMOD
	5117	+* FDB XMACH
	5118	+* PULU D
	5119	+* STB 2,Y track
	5120	+* PULU D
	5121	+* INCB
	5122	+* STB 3,Y sector
	5123	+* PULS D table entry
	5124	+* SUBD #DROFFS+7
	5125	+* ASRB drive #
	5126	+* STB 1,Y
	5127	+* LDD 4,U buffer
	5128	+* STD 4,Y
	5129	+* LDB #2 coco READ
	5130	+* LDX ,U 0?
	5131	+* BNE *+3
	5132	+* INCB coco WRITE
	5133	+* STB ,Y op code
	5134	+* CLRA
	5135	+* TFR A,DP
	5136	+* JSR [$C004] ROM handles timeout
	5137	+* PULS Y,U,DP if IRQ enabled
	5138	+* LEAU 6,U
	5139	+* LDX $C006
	5140	+* LDB 6,X coco status
	5141	+* BEQ RWE
	5142	+* LDX <UP
	5143	+* LDD #0 no disc
	5144	+* STD UWARN,X
	5145	+* LDD #8
	5146	+* PSHU D
	5147	+* JMP ERROR
	5148	+* RWE NEXT
	5149	+*
	5150	+* ######>> screen 72 <<
	5151	+* ======>> 192 <<
	5152	+* ( --- ) compiling P
	5153	+* ( --- adr ) interpreting
	5154	+* { ' name } input
	5155	+* Parse a symbol name from input and search the dictionary for it, per -FIND;
	5156	+* compile the address as a literal if compiling,
	5157	+* otherwise just push it.
	5158	+ FCB $C1 immediate
	5159	+ FCB $A7 ' ( tick )
	5160	+ FDB RW-6
	5161	+TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
	5162	+ FDB SEMIS
	5163	+*
	5164	+* ======>> 193 <<
	5165	+* ( --- ) { FORGET name } input
	5166	+* Parse out name of definition to FORGET to, -DFIND it,
	5167	+* then lop it and everything that follows out of the dictionary.
	5168	+* In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
	5169	+ FCB $86
	5170	+ FCC 'FORGE' ; 'FORGET'
	5171	+ FCB $D4
	5172	+ FDB TICK-4
	5173	+FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
	5174	+ FCB $18
	5175	+ FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT8
	5176	+ FCB $15
	5177	+ FDB QERR,DUP,ZERO,PORIG,GREAT,LIT8
	5178	+ FCB $15
	5179	+ FDB QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
	5180	+ FDB SEMIS
	5181	+*
	5182	+* ######>> screen 73 <<
	5183	+* ======>> 194 <<
	5184	+* ( adr --- ) C
	5185	+* Calculate a back reference from HERE and compile it.
	5186	+ FCB $84
	5187	+ FCC 'BAC' ; 'BACK'
	5188	+ FCB $CB
	5189	+ FDB FORGET-9
	5190	+* BACK FDB DOCOL,HERE,SUB,COMMA
	5191	+BACK FDB DOCOL,HERE,NATP,SUB,COMMA
	5192	+ FDB SEMIS
	5193	+*
	5194	+* ======>> 195 <<
	5195	+* ( --- ) runtime
	5196	+* typical use: BEGIN code-loop test UNTIL
	5197	+* typical use: BEGIN code-loop AGAIN
	5198	+* typical use: BEGIN code-loop test WHILE code-true REPEAT
	5199	+* ( --- adr n ) compile time P,C
	5200	+* Push HERE for BACK reference for general (non-counting) loops,
	5201	+* with BEGIN construct flag.
	5202	+* A better flag: $4245 (ASCII for 'BE').
	5203	+ FCB $C5
	5204	+ FCC 'BEGI' ; 'BEGIN'
	5205	+ FCB $CE
	5206	+ FDB BACK-7
	5207	+BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
	5208	+ FDB SEMIS
	5209	+*
	5210	+* ======>> 196 <<
	5211	+* ( --- ) runtime
	5212	+* typical use: test IF code-true ELSE code-false ENDIF
	5213	+* ENDIF is just a sort of intersection piece,
	5214	+* marking where execution resumes after both branches.
	5215	+* ( adr n --- ) compile time
	5216	+* Check the mark and resolve the IF.
	5217	+* A better flag: $4846 (ASCII for 'IF').
	5218	+ FCB $C5
	5219	+ FCC 'ENDI' ; 'ENDIF'
	5220	+ FCB $C6
	5221	+ FDB BEGIN-8
	5222	+ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
	5223	+* FDB OVER,SUB,SWAP,STORE
	5224	+ FDB OVER,NATP,SUB,SWAP,STORE
	5225	+ FDB SEMIS
	5226	+*
	5227	+* ======>> 197 <<
	5228	+* ( --- ) runtime
	5229	+* typical use: test IF code-true ELSE code-false ENDIF
	5230	+* ( adr n --- )
	5231	+* Alias for ENDIF .
	5232	+ FCB $C4
	5233	+ FCC 'THE' ; 'THEN'
	5234	+ FCB $CE
	5235	+ FDB ENDIF-8
	5236	+THEN FDB DOCOL,ENDIF
	5237	+ FDB SEMIS
	5238	+*
	5239	+* ======>> 198 <<
	5240	+* ( limit index --- ) runtime
	5241	+* typical use: DO code-loop LOOP
	5242	+* typical use: DO code-loop increment +LOOP
	5243	+* Counted loop, index is initial value of index.
	5244	+* Will loop until index equals (positive going)
	5245	+* or passes (negative going) limit.
	5246	+* ( --- adr n ) compile time P,C
	5247	+* Compile (DO), push HERE for BACK reference,
	5248	+* and push DO control construct flag.
	5249	+* A better flag: $444F (ASCII for 'DO').
	5250	+ FCB $C2
	5251	+ FCC 'D' ; 'DO'
	5252	+ FCB $CF
	5253	+ FDB THEN-7
	5254	+DO FDB DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
	5255	+ FDB SEMIS
	5256	+*
	5257	+* ======>> 199 <<
	5258	+* ( --- ) runtime
	5259	+* typical use: DO code-loop LOOP
	5260	+* Increments the index by one and branches back to beginning of loop.
	5261	+* Will loop until index equals limit.
	5262	+* ( adr n --- ) compile time P,C
	5263	+* Check the mark and compile (LOOP), fill in BACK reference.
	5264	+* A better flag: $444F (ASCII for 'DO').
	5265	+ FCB $C4
	5266	+ FCC 'LOO' ; 'LOOP'
	5267	+ FCB $D0
	5268	+ FDB DO-5
	5269	+LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
	5270	+ FDB SEMIS
	5271	+*
	5272	+* ======>> 200 <<
	5273	+* ( n --- ) runtime
	5274	+* typical use: DO code-loop increment +LOOP
	5275	+* Increments the index by n and branches back to beginning of loop.
	5276	+* Will loop until index equals (positive going)
	5277	+* or passes (negative going) limit.
	5278	+* ( adr n --- ) compile time P,C
	5279	+* Check the mark and compile (+LOOP), fill in BACK reference.
	5280	+* A better flag: $444F (ASCII for 'DO').
	5281	+ FCB $C5
	5282	+ FCC '+LOO' ; '+LOOP'
	5283	+ FCB $D0
	5284	+ FDB LOOP-7
	5285	+PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
	5286	+ FDB SEMIS
	5287	+*
	5288	+* ======>> 201 <<
	5289	+* ( n --- ) runtime
	5290	+* typical use: BEGIN code-loop test UNTIL
	5291	+* Will loop until UNTIL tests true.
	5292	+* ( adr n --- ) compile time P,C
	5293	+* Check the mark and compile (0BRANCH), fill in BACK reference.
	5294	+* A better flag: $4245 (ASCII for 'BE').
	5295	+ FCB $C5
	5296	+ FCC 'UNTI' ; 'UNTIL' : ( same as END )
	5297	+ FCB $CC
	5298	+ FDB PLOOP-8
	5299	+UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
	5300	+ FDB SEMIS
	5301	+*
	5302	+* ######>> screen 74 <<
	5303	+* ======>> 202 <<
	5304	+* ( n --- ) runtime
	5305	+* typical use: BEGIN code-loop test END
	5306	+* ( adr n --- )
	5307	+* Alias for UNTIL .
	5308	+ FCB $C3
	5309	+ FCC 'EN' ; 'END'
	5310	+ FCB $C4
	5311	+ FDB UNTIL-8
	5312	+END FDB DOCOL,UNTIL
	5313	+ FDB SEMIS
	5314	+*
	5315	+* ======>> 203 <<
	5316	+* ( --- ) runtime
	5317	+* typical use: BEGIN code-loop AGAIN
	5318	+* Will loop forever
	5319	+* (or until something uses R> DROP to force the current definition to die,
	5320	+* or perhaps ABORT or ERROR or some such other drastic means stops things).
	5321	+* ( adr n --- ) compile time P,C
	5322	+* Check the mark and compile (0BRANCH), fill in BACK reference.
	5323	+* A better flag: $4245 (ASCII for 'BE').
	5324	+ FCB $C5
	5325	+ FCC 'AGAI' ; 'AGAIN'
	5326	+ FCB $CE
	5327	+ FDB END-6
	5328	+AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
	5329	+ FDB SEMIS
	5330	+*
	5331	+* ======>> 204 <<
	5332	+* ( --- ) runtime
	5333	+* typical use: BEGIN code-loop test WHILE code-true REPEAT
	5334	+* Will loop until WHILE tests false, skipping code-true on end.
	5335	+* REPEAT marks where execution resumes after the WHILE find a false flag.
	5336	+* ( aadr1 n1 adr2 n2 --- ) compile time P,C
	5337	+* Check the marks for WHILE and BEGIN,
	5338	+* compile BRANCH and BACK fill adr1 reference,
	5339	+* FILL-IN 0BRANCH reference at adr2.
	5340	+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
	5341	+ FCB $C6
	5342	+ FCC 'REPEA' ; 'REPEAT'
	5343	+ FCB $D4
	5344	+ FDB AGAIN-8
	5345	+REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
	5346	+ FDB TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
	5347	+ FDB SEMIS
	5348	+*
	5349	+* ======>> 205 <<
	5350	+* ( n --- ) runtime
	5351	+* typical use: test IF code-true ELSE code-false ENDIF
	5352	+* Will pass execution to the true part on a true flag
	5353	+* and to the false part on a false flag.
	5354	+* ( --- adr n ) compile time P,C
	5355	+* Compile a 0BRANCH and dummy offset
	5356	+* and push IF reference to fill in and
	5357	+* IF control construct flag.
	5358	+* A better flag: $4946 (ASCII for 'IF').
	5359	+ FCB $C2
	5360	+ FCC 'I' ; 'IF'
	5361	+ FCB $C6
	5362	+ FDB REPEAT-9
	5363	+IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
	5364	+ FDB SEMIS
	5365	+*
	5366	+* ======>> 206 <<
	5367	+* ( --- ) runtime
	5368	+* typical use: test IF code-true ELSE code-false ENDIF
	5369	+* ELSE is just a sort of intersection piece,
	5370	+* marking where execution resumes on a false branch.
	5371	+* ( adr1 n --- adr2 n ) compile time P,C
	5372	+* Check the marks,
	5373	+* compile BRANCH with dummy offset,
	5374	+* resolve IF reference,
	5375	+* and leave reference to BRANCH for ELSE.
	5376	+* A better flag: $4946 (ASCII for 'IF').
	5377	+ FCB $C4
	5378	+ FCC 'ELS' ; 'ELSE'
	5379	+ FCB $C5
	5380	+ FDB IF-5
	5381	+ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
	5382	+ FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
	5383	+ FDB SEMIS
	5384	+*
	5385	+* ======>> 207 <<
	5386	+* ( n --- ) runtime
	5387	+* typical use: BEGIN code-loop test WHILE code-true REPEAT
	5388	+* Will loop until WHILE tests false, skipping code-true on end.
	5389	+* ( --- adr n ) compile time P,C
	5390	+* Compile 0BRANCH with dummy offset (using IF),
	5391	+* push WHILE reference.
	5392	+* BEGIN flag will sit underneath this.
	5393	+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
	5394	+ FCB $C5
	5395	+ FCC 'WHIL' ; 'WHILE'
	5396	+ FCB $C5
	5397	+ FDB ELSE-7
	5398	+WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
	5399	+ FDB SEMIS
	5400	+*
	5401	+* ######>> screen 75 <<
	5402	+* ======>> 208 <<
	5403	+* ( count --- )
	5404	+* EMIT count spaces, for non-zero, non-negative counts.
	5405	+ FCB $86
	5406	+ FCC 'SPACE' ; 'SPACES'
	5407	+ FCB $D3
	5408	+ FDB WHILE-8
	5409	+SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
	5410	+ FDB SPACE3-*-NATWID
	5411	+ FDB ZERO,XDO
	5412	+SPACE2 FDB SPACE,XLOOP
	5413	+ FDB SPACE2-*-NATWID
	5414	+SPACE3 FDB SEMIS
	5415	+*
	5416	+* ======>> 209 <<
	5417	+* ( --- )
	5418	+* Initialize HLD for converting a double integer.
	5419	+* Stores the PAD address in HLD.
	5420	+ FCB $82
	5421	+ FCC '<' ; '<#'
	5422	+ FCB $A3
	5423	+ FDB SPACES-9
	5424	+BDIGS FDB DOCOL,PAD,HLD,STORE
	5425	+ FDB SEMIS
	5426	+*
	5427	+* ======>> 210 <<
	5428	+* ( d --- string length )
	5429	+* Terminate numeric conversion,
	5430	+* drop the number being converted,
	5431	+* leave the address of the conversion string and the length, ready for TYPE.
	5432	+ FCB $82
	5433	+ FCC '#' ; '#>'
	5434	+ FCB $BE
	5435	+ FDB BDIGS-5
	5436	+EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
	5437	+ FDB SEMIS
	5438	+*
	5439	+* ======>> 211 <<
	5440	+* ( n d --- d )
	5441	+* Put sign of n (as a flag) at the head of the conversion string.
	5442	+* Drop the sign flag.
	5443	+ FCB $84
	5444	+ FCC 'SIG' ; 'SIGN'
	5445	+ FCB $CE
	5446	+ FDB EDIGS-5
	5447	+SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
	5448	+ FDB SIGN2-*-NATWID
	5449	+ FDB LIT8
	5450	+ FCC "-"
	5451	+ FDB HOLD
	5452	+SIGN2 FDB SEMIS
	5453	+*
	5454	+* ======>> 212 <<
	5455	+* ( d --- d/base )
	5456	+* Generate next most significant digit in the conversion BASE,
	5457	+* putting the digit at the head of the conversion string.
	5458	+ FCB $81 #
	5459	+ FCB $A3
	5460	+ FDB SIGN-7
	5461	+DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
	5462	+ FCB 9
	5463	+ FDB OVER,LESS,ZBRAN
	5464	+ FDB DIG2-*-NATWID
	5465	+ FDB LIT8
	5466	+ FCB 7
	5467	+ FDB PLUS
	5468	+DIG2 FDB LIT8
	5469	+ FCC "0" ascii zero
	5470	+ FDB PLUS,HOLD
	5471	+ FDB SEMIS
	5472	+*
	5473	+* ======>> 213 <<
	5474	+* ( d --- dzero )
	5475	+* Convert d to a numeric string using # until the result is zero.
	5476	+* Leave the double result on the stack for #> to drop.
	5477	+ FCB $82
	5478	+ FCC '#' ; '#S'
	5479	+ FCB $D3
	5480	+ FDB DIG-4
	5481	+DIGS FDB DOCOL
	5482	+DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
	5483	+ FDB DIGS2-*-NATWID
	5484	+ FDB SEMIS
	5485	+*
	5486	+* ######>> screen 76 <<
	5487	+* ======>> 214 <<
	5488	+* ( n width --- )
	5489	+* Print n on the output device in the current conversion base,
	5490	+* with sign,
	5491	+* right aligned in a field at least width wide.
	5492	+ FCB $82
	5493	+ FCC '.' ; '.R'
	5494	+ FCB $D2
	5495	+ FDB DIGS-5
	5496	+DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
	5497	+ FDB SEMIS
	5498	+*
	5499	+* ======>> 215 <<
	5500	+* ( d width --- )
	5501	+* Print d on the output device in the current conversion base,
	5502	+* with sign,
	5503	+* right aligned in a field at least width wide.
	5504	+ FCB $83
	5505	+ FCC 'D.' ; 'D.R'
	5506	+ FCB $D2
	5507	+ FDB DOTR-5
	5508	+DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
	5509	+ FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
	5510	+ FDB SEMIS
	5511	+*
	5512	+* ======>> 216 <<
	5513	+* D. ( d --- )
	5514	+* Print d on the output device in the current conversion base,
	5515	+* with sign,
	5516	+* in free format with trailing space.
	5517	+ FCB $82
	5518	+ FCC 'D' ; 'D.'
	5519	+ FCB $AE
	5520	+ FDB DDOTR-6
	5521	+DDOT FDB DOCOL,ZERO,DDOTR,SPACE
	5522	+ FDB SEMIS
	5523	+*
	5524	+* ======>> 217 <<
	5525	+* ( n --- )
	5526	+* Print n on the output device in the current conversion base,
	5527	+* with sign,
	5528	+* in free format with trailing space.
	5529	+ FCB $81 .
	5530	+ FCB $AE
	5531	+ FDB DDOT-5
	5532	+DOT FDB DOCOL,STOD,DDOT
	5533	+ FDB SEMIS
	5534	+*
	5535	+* ======>> 218 <<
	5536	+* ( adr --- )
	5537	+* Print signed word at adr, per DOT.
	5538	+ FCB $81 ?
	5539	+ FCB $BF
	5540	+ FDB DOT-4
	5541	+QUEST FDB DOCOL,AT,DOT
	5542	+ FDB SEMIS
	5543	+*
	5544	+* ######>> screen 77 <<
	5545	+* ======>> 219 <<
	5546	+* ( n --- )
	5547	+* Print out screen n as a field of ASCII,
	5548	+* with line numbers in decimal.
	5549	+* Needs a console more than 70 characters wide.
	5550	+ FCB $84
	5551	+ FCC 'LIS' ; 'LIST'
	5552	+ FCB $D4
	5553	+ FDB QUEST-4
	5554	+LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
	5555	+ FCB 6
	5556	+ FCC "SCR # "
	5557	+ FDB DOT,LIT8
	5558	+ FCB $10
	5559	+ FDB ZERO,XDO
	5560	+LIST2 FDB CR,I,THREE
	5561	+ FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
	5562	+ FDB LIST2-*-NATWID
	5563	+ FDB CR
	5564	+ FDB SEMIS
	5565	+*
	5566	+* ======>> 220 <<
	5567	+* ( start end --- )
	5568	+* Print comment lines (line 0, and line 1 if C/L < 41) of screens
	5569	+* from start to end.
	5570	+* Needs a console more than 70 characters wide.
	5571	+ FCB $85
	5572	+ FCC 'INDE' ; 'INDEX'
	5573	+ FCB $D8
	5574	+ FDB LIST-7
	5575	+INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
	5576	+INDEX2 FDB CR,I,THREE
	5577	+ FDB DOTR,SPACE,ZERO,I,DLINE
	5578	+ FDB QTERM,ZBRAN
	5579	+ FDB INDEX3-*-NATWID
	5580	+ FDB LEAVE
	5581	+INDEX3 FDB XLOOP
	5582	+ FDB INDEX2-*-NATWID
	5583	+ FDB SEMIS
	5584	+*
	5585	+* ======>> 221 <<
	5586	+* ( n --- )
	5587	+* List a printer page full of screens.
	5588	+* Line and screen number are in current base.
	5589	+* Needs a console more than 70 characters wide.
	5590	+ FCB $85
	5591	+ FCC 'TRIA' ; 'TRIAD'
	5592	+ FCB $C4
	5593	+ FDB INDEX-8
	5594	+TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
	5595	+ FDB THREE,OVER,PLUS,SWAP,XDO
	5596	+TRIAD2 FDB CR,I
	5597	+ FDB LIST,QTERM,ZBRAN
	5598	+ FDB TRIAD3-*-NATWID
	5599	+ FDB LEAVE
	5600	+TRIAD3 FDB XLOOP
	5601	+ FDB TRIAD2-*-NATWID
	5602	+ FDB CR,LIT8
	5603	+ FCB $0F
	5604	+ FDB MESS,CR
	5605	+ FDB SEMIS
	5606	+*
	5607	+* ######>> screen 78 <<
	5608	+* ======>> 222 <<
	5609	+* ( --- )
	5610	+* Alphabetically list the definitions in the current vocabulary.
	5611	+* Expects to output to printer, not TRS80 Color Computer screen.
	5612	+ FCB $85
	5613	+ FCC 'VLIS' ; 'VLIST'
	5614	+ FCB $D4
	5615	+ FDB TRIAD-8
	5616	+VLIST FDB DOCOL,LIT8
	5617	+ FCB $80
	5618	+ FDB OUT,STORE,CONTXT,AT,AT
	5619	+VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
	5620	+ FCB 32
	5621	+ FDB SUB,GREAT,ZBRAN
	5622	+ FDB VLIST2-*-NATWID
	5623	+ FDB CR,ZERO,OUT,STORE
	5624	+VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
	5625	+ FDB DUP,ZEQU,QTERM,OR,ZBRAN
	5626	+ FDB VLIST1-*-NATWID
	5627	+ FDB DROP
	5628	+ FDB SEMIS
	5629	+*
	5630	+* Need some utility stuff that isn't in the fig FORTH:
	5631	+* ( c --- )
	5632	+* Emit dot if c is less than blank, else emit c
	5633	+ FCB $85
	5634	+ FCC 'BEMI' ; 'BEMIT'
	5635	+ FCB $D4 ; 'T'
	5636	+ FDB VLIST-8
	5637	+BEMIT FDB DOCOL
	5638	+ FDB DUP,BL,LESS,ZBRAN
	5639	+ FDB BEMITO-*-NATWID
	5640	+ FDB DROP,LIT8
	5641	+ FCB $2e ; '.'
	5642	+BEMITO FDB EMIT
	5643	+ FDB SEMIS
	5644	+*
	5645	+* ( n width --- )
	5646	+* Output n in hexadecimal field width.
	5647	+ FCB $83
	5648	+ FCC 'X.' ; 'X.R'
	5649	+ FCB $D2 ; 'R'
	5650	+ FDB BEMIT-8
	5651	+XDOTR FDB DOCOL
	5652	+ FDB BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
	5653	+ FDB SEMIS
	5654	+*
	5655	+* ( adr --- )
	5656	+* Dump a line of 4 bytes in memory, in hex and as characters.
	5657	+ FCB $85
	5658	+ FCC 'BLIN' ; 'BLINE'
	5659	+ FCB $C5 ; 'E'
	5660	+ FDB XDOTR-6
	5661	+BLINE FDB DOCOL
	5662	+ FDB DUP,LIT8
	5663	+ FCB 4
	5664	+ FDB PLUS,OVER,XDO
	5665	+BLINEX FDB I,CAT,THREE,XDOTR,XLOOP
	5666	+ FDB BLINEX-*-NATWID
	5667	+ FDB SPACE,SPACE
	5668	+ FDB DUP,LIT8
	5669	+ FCB 4
	5670	+ FDB PLUS,SWAP,XDO
	5671	+BLINEC FDB I,CAT,BEMIT,XLOOP
	5672	+ FDB BLINEC-*-NATWID
	5673	+ FDB SEMIS
	5674	+*
	5675	+* ( start end --- )
	5676	+* Dump 4 byte lines from start to end.
	5677	+ FCB $85
	5678	+ FCC 'BDUM' ; 'BDUMP'
	5679	+ FCB $D0 ; '5'
	5680	+ FDB BLINE-8
	5681	+BDUMP FDB DOCOL
	5682	+ FDB CR,XDO
	5683	+BDUMPL FDB I,LIT8
	5684	+ FCB 4
	5685	+ FDB XDOTR,LIT8
	5686	+ FCB $3A
	5687	+ FDB EMIT,SPACE
	5688	+ FDB I,BLINE,CR,LIT8
	5689	+ FCB 4
	5690	+ FDB XPLOOP
	5691	+ FDB BDUMPL-*-NATWID
	5692	+ FDB SEMIS
	5693	+*
	5694	+* ======>> XX <<
	5695	+* ( --- )
	5696	+* Mostly for place holding (fig Forth).
	5697	+ FCB $84
	5698	+ FCC 'NOO' ; 'NOOP'
	5699	+ FCB $D0
	5700	+ FDB BDUMP-8
	5701	+NOOP FDB *+NATWID
	5702	+ LBRA NEXT
	5703	+* NOOP NEXT a useful no-op
	5704	+ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
	5705	+
	5706	+ PAGE
	5707	+* These things, up through the lable 'REND', are overwritten
	5708	+* at time of cold load and should have the same contents
	5709	+* as shown here:
	5710	+*
	5711	+* This can be moved whereever the bottom of the
	5712	+* user's dictionary is going to be put.
	5713	+*
	5714	+RBEG EQU *
	5715	+ FCB $C5 immediate
	5716	+ FCC 'FORT' ; 'FORTH'
	5717	+ FCB $C8
	5718	+ FDB NOOP-7
	5719	+FORTH FDB DODOES,DOVOC,$81A0,TASK-7
	5720	+ FDB 0
	5721	+*
	5722	+ FCC "Copyright 1979 Forth Interest Group, David Lion,"
	5723	+ FCB $0D
	5724	+ FCC "Parts Copyright 2019 Joel Matthew Rees"
	5725	+ FCB $0D
	5726	+*
	5727	+ FCB $84
	5728	+ FCC 'TAS' ; 'TASK'
	5729	+ FCB $CB
	5730	+ FDB FORTH-8
	5731	+TASK FDB DOCOL,SEMIS
	5732	+*
	5733	+REND EQU * ( first empty location in dictionary )
	5734	+RSIZE EQU *-RBEG ; So we can look at it.
	5735	+ PAGE
	5736	+
	5737	+ ORG RAMDSK
	5738	+* "0 1 2 3 4 5 6 " ;
	5739	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5740	+ FCC " 0) Index page " ; 0
	5741	+ FCC " 1) empty line on line 1 of screen 0 block 0 " ; 1
	5742	+ FCC " 2) Title and copyright " ; 2
	5743	+ FCC " 3) empty line on line 3 of screen 0 block 0 " ; 3
	5744	+ FCC " 4) Error messages 1st screen " ; 4
	5745	+ FCC " 5) Error messages 2nd screen " ; 5
	5746	+ FCC " 6) empty line 3 screen 0 block 1 " ; 6
	5747	+ FCC " 7) empty line 4 " ; 7
	5748	+ FCC " 8) and line 1 of block 2 " ; 8
	5749	+ FCC " 9) line 2 of block 2 screen 0 is pretty much empty too " ; 9
	5750	+ FCC " 10) listen to this. Line three of block two is too " ; 10
	5751	+ FCC " 11) and so is line 4 4 4 4 4 4 4 4 4 4 b2s0 " ; 11
	5752	+ FCC " 12) screen zero block three first line " ; 12
	5753	+ FCC " 13) second line fourth block (block three) screen 0 " ; 13
	5754	+ FCC " 14) block three screen zero line 3 3 3 3 3 3 3 3 3 " ; 14
	5755	+ FCC " 15) fourth line block three screen 0 0 0 0 0 0 0 0 0 0 " ; 15
	5756	+* "0 1 2 3 4 5 6 " ;
	5757	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5758	+ FCC " test 10 b0s1 aaaa " ; 0
	5759	+ FCC " test 11 b0s1 ee ee ee ee " ; 1
	5760	+ FCC " test 12 b0s1 oo oo oo oo oo " ; 2
	5761	+ FCC " test 13 b0s1 eh ehe he eh eh " ; 3
	5762	+ FCC " ( block 1 ) b1s1 oh ohoo oh oh oh " ; 4
	5763	+ FCC " 15 test b1s1 " ; 5
	5764	+ FCC " 16 test b1s1 " ; 6
	5765	+ FCC " 17 test b1s1 " ; 7
	5766	+ FCC " 18 test b2s1 " ; 8
	5767	+ FCC " 19 test b2s1 " ; 9
	5768	+ FCC " 1A test b2s1 " ; 10
	5769	+ FCC " 1B test b2ws1 " ; 11
	5770	+ FCC " 1C test b3s1 " ; 12
	5771	+ FCC " 1D test b3s1 " ; 13
	5772	+ FCC " 1e this completes our second screen b3s1 " ; 14
	5773	+ FCC " 1F test b3s1 " ; 15
	5774	+* "0 1 2 3 4 5 6 " ;
	5775	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5776	+ FCC " " ; 0
	5777	+ FCC " fig Forth High Level Model Code " ; 1
	5778	+ FCC " " ; 2
	5779	+ FCC " Copyright 2018 Joel Matthew Rees " ; 3
	5780	+ FCC " ( block 2 ) " ; 4
	5781	+ FCC " " ; 5
	5782	+ FCC " " ; 6
	5783	+ FCC " " ; 7
	5784	+ FCC " " ; 8
	5785	+ FCC " " ; 9
	5786	+ FCC " " ; 10
	5787	+ FCC " " ; 11
	5788	+ FCC " " ; 12
	5789	+ FCC " " ; 13
	5790	+ FCC " " ; 14
	5791	+ FCC " " ; 15
	5792	+* "0 1 2 3 4 5 6 " ;
	5793	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5794	+ FCC " " ; 0
	5795	+ FCC " " ; 1
	5796	+ FCC " " ; 2
	5797	+ FCC " " ; 3
	5798	+ FCC " ( block 3 ) " ; 4
	5799	+ FCC " " ; 5
	5800	+ FCC " " ; 6
	5801	+ FCC " " ; 7
	5802	+ FCC " " ; 8
	5803	+ FCC " " ; 9
	5804	+ FCC " " ; 10
	5805	+ FCC " " ; 11
	5806	+ FCC " " ; 12
	5807	+ FCC " " ; 13
	5808	+ FCC " " ; 14
	5809	+ FCC " " ; 15
	5810	+* "0 1 2 3 4 5 6 " ;
	5811	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5812	+ FCC " " ; 0
	5813	+ FCC " " ; 1
	5814	+ FCC " " ; 2
	5815	+ FCC " " ; 3
	5816	+ FCC " ( block 4 ) " ; 4
	5817	+ FCC " " ; 5
	5818	+ FCC " " ; 6
	5819	+ FCC " " ; 7
	5820	+ FCC " " ; 8
	5821	+ FCC " " ; 9
	5822	+ FCC " " ; 10
	5823	+ FCC " " ; 11
	5824	+ FCC " " ; 12
	5825	+ FCC " " ; 13
	5826	+ FCC " " ; 14
	5827	+ FCC " " ; 15
	5828	+* "0 1 2 3 4 5 6 " ;
	5829	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5830	+ FCC " ( ERROR MESSAGES ) " ; 0
	5831	+ FCC " DATA STACK UNDERFLOW " ; 1
	5832	+ FCC " DICTIONARY FULL " ; 2
	5833	+ FCC " ADDRESS RESOLUTION ERROR " ; 3
	5834	+ FCC " HIDES DEFINITION IN " ; 4
	5835	+ FCC " " ; 5
	5836	+ FCC " " ; 6
	5837	+ FCC " " ; 7
	5838	+ FCC " " ; 8
	5839	+ FCC " " ; 9
	5840	+ FCC " " ; 10
	5841	+ FCC " " ; 11
	5842	+ FCC " " ; 12
	5843	+ FCC " " ; 13
	5844	+ FCC " " ; 14
	5845	+ FCC " " ; 15
	5846	+* "0 1 2 3 4 5 6 " ;
	5847	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5848	+ FCC " more test data 2 3 4 5 6 " ; 0
	5849	+ FCC "0123456789012345678901234567890123456789012345678901234567890123" ; 1
	5850	+ FCC "Test data for the RAM disc emulator buffers. " ; 2
	5851	+ FCC " " ; 3
	5852	+ FCC " ( block 6 ) " ; 4
	5853	+ FCC " " ; 5
	5854	+ FCC " " ; 6
	5855	+ FCC " " ; 7
	5856	+ FCC " " ; 8
	5857	+ FCC " " ; 9
	5858	+ FCC " " ; 10
	5859	+ FCC " " ; 11
	5860	+ FCC " " ; 12
	5861	+ FCC " " ; 13
	5862	+ FCC " " ; 14
	5863	+ FCC " end" ; 15
	5864	+RAMDND EQU *
	5865	+
	5866	+
	5867	+ PAGE
	5868	+ OPT L
	5869	+ END

--- /dev/null

+++ b/fig-forth-6809_ret.asm

		@@ -0,0 +1,5826 @@
	1	+ OPT PRT
	2	+
	3	+* fig-FORTH FOR 6809
	4	+* ASSEMBLY SOURCE LISTING
	5	+
	6	+* RELEASE 0
	7	+* JAN 2019
	8	+* WITH COMPILER SECURITY
	9	+* AND VARIABLE LENGTH NAMES
	10	+* Using RTS mode
	11	+*
	12	+* Adapted by Joel Matthew Rees
	13	+* from fig-FORTH for 6800 by Dave Lion, et. al.
	14	+
	15	+* This free/libre/open source publication is provided
	16	+* through the courtesy of:
	17	+* FORTH
	18	+* INTEREST
	19	+* GROUP
	20	+* fig
	21	+* and other interested parties.
	22	+
	23	+* Ancient address:
	24	+* P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
	25	+* URL: http://www.forth.org
	26	+* Further distribution must include this notice.
	27	+ PAGE
	28	+ NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
	29	+ OPT NOG,PAG
	30	+* filename fig-forth-auto6809opt.asm
	31	+* === FORTH-6809 {date} {time}
	32	+
	33	+
	34	+* Permission is hereby granted, free of charge, to any person obtaining a copy
	35	+* of this software and associated documentation files (the "Software"), to deal
	36	+* in the Software without restriction, including without limitation the rights
	37	+* to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
	38	+* copies of the Software, and to permit persons to whom the Software is
	39	+* furnished to do so, subject to the following conditions:
	40	+*
	41	+* The above copyright notice and this permission notice shall be included in
	42	+* all copies or substantial portions of the Software.
	43	+
	44	+* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
	45	+* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
	46	+* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
	47	+* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
	48	+* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
	49	+* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
	50	+* THE SOFTWARE.
	51	+*
	52	+* "Associated documentation" for this declaration of license
	53	+* shall be interpreted to include only the comments in this file,
	54	+* or, if the code is split into multiple files,
	55	+* all files containing the complete source.
	56	+*
	57	+* This is the MIT model license, as published by the Open Source Consortium,
	58	+* with associated documentation defined.
	59	+* It was chosen to reflect the spirit of the original
	60	+* terms of use, which used archaic legal terminology.
	61	+*
	62	+
	63	+* Authors of the 6800 model:
	64	+* === Primary: Dave Lion,
	65	+* === with help from
	66	+* === Bob Smith,
	67	+* === LaFarr Stuart,
	68	+* === The Forth Interest Group
	69	+* === PO Box 1105
	70	+* === San Carlos, CA 94070
	71	+* === and
	72	+* === Unbounded Computing
	73	+* === 1134-K Aster Ave.
	74	+* === Sunnyvale, CA 94086
	75	+*
	76	+NATWID EQU 2 ; bytes per natural integer/pointer
	77	+* The original version was developed on an AMI EVK 300 PROTO
	78	+* system using an ACIA for the I/O.
	79	+* This version is developed targeting the Tandy Color Computer.
	80	+
	81	+* All terminal 1/0
	82	+* is done in three subroutines:
	83	+* PEMIT ( word # 182 )
	84	+* PKEY ( 183 )
	85	+* PQTERM ( 184 )
	86	+*
	87	+* The FORTH words for disc related I/O follow the model
	88	+* of the FORTH Interest Group, but have not yet been
	89	+* tested using a real disc.
	90	+*
	91	+* Addresses in the 6800 implementation reflect the fact that,
	92	+* on the development system, it was convenient to
	93	+* write-protect memory at hex 1000, and leave the first
	94	+* 4K bytes write-enabled. As a consequence, code from
	95	+* location $1000 to lable ZZZZ could be put in ROM.
	96	+* Minor deviations from the model were made in the
	97	+* initialization and words ?STACK and FORGET
	98	+* in order to do this.
	99	+* Those deviations will be altered in this
	100	+* implementation for the 6809 -- Color Computer.
	101	+*
	102	+
	103	+* MEMORY MAP for this 16K\|32K system:
	104	+* ( delineated so that systems with 4k byte write-
	105	+* protected segments can write protect FORTH )
	106	+*
	107	+* addr. contents pointer init by
	108	+* ** *************************** *** ****
	109	+*
	110	+* Coco has no ACIA!
	111	+* ACIAC EQU $FBCE the ACIA control address and
	112	+* ACIAD EQU ACIAC+1 data address for PROTO
	113	+*
	114	+MEMT32 EQU $7FFF ; Theoretical absolute end of all ram
	115	+MEMT16 EQU $3FFF ; 16K is too tight until we no longer need disc emulation.
	116	+MEMTOP EQU MEMT32
	117	+*
	118	+MASSHI EQU MEMTOP
	119	+*
	120	+* 3FFF\|7FFF HI
	121	+*
	122	+* substitute for disc mass memory
	123	+RAMSCR EQU 8 ; addresses calculate as 2 (Too much for 16K in RAM only.)
	124	+SCRSZ EQU 1024
	125	+* 3800\|7800 LO
	126	+MASSLO EQU MASSHI-RAMSCR*SCRSZ+1
	127	+RAMDSK EQU MASSLO
	128	+MEMEND EQU MASSLO
	129	+*
	130	+* 3800\|7800 MEMEND
	131	+* "end" of "usable ram" (If disc mass memory emulation is removed, actual end.)
	132	+*
	133	+* 37FF\|77FF
	134	+*
	135	+* per-user tables
	136	+USERSZ EQU 256 ; (Addressable by DP, must be 256 on even boundary)
	137	+USER16 EQU 1 ; We can change these for ROMPACK or 64K.
	138	+USER32 EQU 2 ; maybe?
	139	+USERCT EQU USER32
	140	+USERLO EQU MEMEND-USERSZ*USERCT
	141	+IUP EQU USERLO
	142	+IUPDP EQU IUP/256
	143	+* user tables of variables
	144	+* registers & pointers for the virtual machine
	145	+* scratch area for potential use in something, maybe?
	146	+*
	147	+* 3700\|7600 <== UP
	148	+*
	149	+* This is a really awkward place to define the disk buffer records.
	150	+*
	151	+* 4 buffer sectors of VIRTUAL MEMORY
	152	+NBLK EQU 4 ; # of disc buffer blocks for virtual memory
	153	+* Should NBLK be SCRSZ/SECTSZ?
	154	+* each block is SECTSZ+SECTRL bytes in size,
	155	+* holding SECTSZ characters
	156	+SECTSZ EQU 256
	157	+SECTRL EQU 2*NATWID ; Currently held sector number, etc.
	158	+BUFSZ EQU (SECTSZ+SECTRL)*NBLK
	159	+BUFBAS EQU USERLO-BUFSZ
	160	+* BUG SECTRL is hard-wired into several definitions.
	161	+* It will take a bit of work to ferret them out.
	162	+* It is too small, and it should not be hard-wired.
	163	+* SECTSZ was also hard-wired into several definitions,
	164	+* will I find them all?
	165	+*
	166	+* 32E0\|71E0 FIRST
	167	+*
	168	+ PAGE
	169	+*
	170	+* Don't want one return too many to destroy the disc buffers.
	171	+RPBUMP EQU 4*NATWID
	172	+*
	173	+* 32D8\|71D8 <== RP RINIT
	174	+*
	175	+IRP EQU BUFBAS-RPBUMP
	176	+* RETURN STACK
	177	+RSTK16 EQU $50*NATWID ; 80 max levels nesting calls
	178	+RSTK32 EQU $90*NATWID ; 144 max
	179	+RSTKSZ EQU RSTK32
	180	+*
	181	+* 3248\|70B8
	182	+*
	183	+SFTBND EQU IRP-RSTKSZ ; (false boundary between TIB and return stack)
	184	+* INPUT LINE BUFFER
	185	+* holds up to TIBSZ characters
	186	+* and is scanned upward by IN
	187	+* starting at TIB
	188	+TIBSZ EQU 256
	189	+ITIB EQU SFTBND-TIBSZ
	190	+*
	191	+* 3148\|6FB8 <== IN TIB
	192	+*
	193	+* Don't want terminal input and parameter underflow collisions
	194	+SPBUMP EQU 4*NATWID
	195	+*
	196	+ISP EQU ITIB-SPBUMP
	197	+*
	198	+* 3140\|6FB0 <== SP SP0,SINIT
	199	+* DATA STACK
	200	+* \| grows downward from 3140\|6FB0
	201	+* v
	202	+* - -
	203	+* ^
	204	+* \|
	205	+* I DICTIONARY grows upward
	206	+*
	207	+* >>>>>>--------Two words to start RAMmable dictionary--------<<<<<<
	208	+*
	209	+* (2B00)
	210	+* ???? end of ram-dictionary. <== DICTPT DPINIT
	211	+* "TASK"
	212	+*
	213	+* ???? "FORTH" ( a word ) <=, <== CONTEXT
	214	+* `==== CURRENT
	215	+* start of ram-dictionary.
	216	+*
	217	+* >>>>>> memory from here up must be in RAM area <<<<<<
	218	+*
	219	+* ????
	220	+* 6k of romable "FORTH" <== IP ABORT
	221	+* <== W
	222	+* the VIRTUAL FORTH MACHINE
	223	+*
	224	+* 1208 initialization tables
	225	+* 1204 <<< WARM START ENTRY >>>
	226	+* 1200 <<< COLD START ENTRY >>>
	227	+* 1200 lowest address used by FORTH
	228	+*
	229	+CODEBG EQU $1200
	230	+* CODEBG EQU $3000
	231	+*
	232	+* >>>>>> memory from here down left alone <<<<<<
	233	+* >>>>>> so we can safely call ROM routines <<<<<<
	234	+*
	235	+* 0000
	236	+ PAGE
	237	+***
	238	+*
	239	+* CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
	240	+*
	241	+* IP (hardware Y) points to the current instruction ( pre-increment mode )
	242	+* RP (hardware S) points to last return address pushedin return stack
	243	+* SP (hardware U) points to last byte pushed in data stack
	244	+*
	245	+* Y must be IP when NEXT is entered (if using the inner loop).
	246	+*
	247	+* When A and B hold one 16 bit FORTH data word,
	248	+* A contains the high byte, B, the low byte.
	249	+*
	250	+* UP (hardware DP) is the base of per-task ("user") variables.
	251	+* (Be careful of the stray semantics of "user".)
	252	+*
	253	+* W (hardware X) is the pointer to the "code field" address of native CPU
	254	+* machine code to be executed for the definition of the dictionary word
	255	+* to be executed/currently executing.
	256	+* The following natural integer (word) begins any "parameter section"
	257	+* (body) -- similar to a "this" pointer, but not the same.
	258	+* It may be native CPU machine code, or it may be a global variable,
	259	+* or it may be a list of Forth definition words (addresses).
	260	+*
	261	+* ======
	262	+* This implementation uses the native subroutine architecture
	263	+* rather than a postponed-push call that the 6800 model VM uses
	264	+* to save code and time in leaf routines.
	265	+*
	266	+* This should allow directly calling many of the Forth words
	267	+* from assembly language code.
	268	+* (Be aware of the need for a valid W in some cases.)
	269	+* It won't allow mixing assembly language directly into Forth word lists.
	270	+* ======
	271	+*
	272	+* boolean flags:
	273	+* 0 is false, anything else is true.
	274	+* Most places in this model that set a boolean flag set true as 1.
	275	+* This is in contrast to many models that set a boolean flag as -1.
	276	+*
	277	+***
	278	+
	279	+ PAGE
	280	+* This system is shown with one user (task),
	281	+* but additional users (tasks) may be added
	282	+* by allocating additional user tables:
	283	+*
	284	+ ORG IUP
	285	+UBASE RMB USERSZ
	286	+UBASEX RMB USERSZ data table for extra users
	287	+*
	288	+* Some of this stuff gets initialized during
	289	+* COLD start and WARM start:
	290	+* [ names correspond to FORTH words of similar (no X) name ]
	291	+*
	292	+ ORG IUP
	293	+UORIG EQU *
	294	+* A few useful VM variables
	295	+* Will be removed when they are no longer needed.
	296	+* All are replaced by 6809 registers.
	297	+
	298	+N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
	299	+* SP@,SWAP,DOES>,COLD
	300	+
	301	+
	302	+* These locations are used by the TRACE routine :
	303	+
	304	+TRLIM RMB 1 the count for tracing without user intervention
	305	+TRACEM RMB 1 non-zero = trace mode
	306	+BRKPT RMB 2 the breakpoint address at which
	307	+* the program will go into trace mode
	308	+VECT RMB 2 vector to machine code
	309	+* (only needed if the TRACE routine is resident)
	310	+
	311	+
	312	+* Registers used by the FORTH virtual machine:
	313	+* Starting at $OOFO:
	314	+
	315	+
	316	+W RMB 2 the instruction register points to 6800 code
	317	+* This is not exactly accurate. Points to the definiton body,
	318	+* which is native CPU machine code when it is native CPU machine code.
	319	+* IP RMB 2 the instruction pointer points to pointer to 6800 code
	320	+* RP RMB 2 the return stack pointer
	321	+* UP RMB 2 the pointer to base of current user's 'USER' table
	322	+* ( altered during multi-tasking )
	323	+*
	324	+*UORIG RMB 6 3 reserved variables
	325	+ RMB 6 3 reserved variables
	326	+XSPZER RMB 2 initial top of data stack for this user
	327	+XRZERO RMB 2 initial top of return stack
	328	+XTIB RMB 2 start of terminal input buffer
	329	+XWIDTH RMB 2 name field width
	330	+XWARN RMB 2 warning message mode (0 = no disc)
	331	+XFENCE RMB 2 fence for FORGET
	332	+XDICTP RMB 2 dictionary pointer
	333	+XVOCL RMB 2 vocabulary linking
	334	+XBLK RMB 2 disc block being accessed
	335	+XIN RMB 2 scan pointer into the block
	336	+XOUT RMB 2 cursor position
	337	+XSCR RMB 2 disc screen being accessed ( O=terminal )
	338	+XOFSET RMB 2 disc sector offset for multi-disc
	339	+XCONT RMB 2 last word in primary search vocabulary
	340	+XCURR RMB 2 last word in extensible vocabulary
	341	+XSTATE RMB 2 flag for 'interpret' or 'compile' modes
	342	+XBASE RMB 2 number base for I/O numeric conversion
	343	+XDPL RMB 2 decimal point place
	344	+XFLD RMB 2
	345	+XCSP RMB 2 current stack position, for compile checks
	346	+XRNUM RMB 2
	347	+XHLD RMB 2
	348	+XDELAY RMB 2 carriage return delay count
	349	+XCOLUM RMB 2 carriage width
	350	+IOSTAT RMB 2 last acia status from write/read
	351	+ RMB 2 ( 4 spares! )
	352	+ RMB 2
	353	+ RMB 2
	354	+ RMB 2
	355	+
	356	+
	357	+
	358	+
	359	+*
	360	+*
	361	+* end of user table, start of common system variables
	362	+*
	363	+*
	364	+*
	365	+* These need to be moved to where they will be
	366	+* initialized globals in variable space, not in the USER table.
	367	+* Or, more accurately, need to be turned into monitored or semaphored resources.
	368	+XUSE RMB 2
	369	+XPREV RMB 2
	370	+ RMB 4 ( spares )
	371	+
	372	+ PAGE
	373	+* The FORTH program ( address $1200 to about $27FF ) will be written
	374	+* so that it can be in a ROM, or write-protected if desired,
	375	+* but right now we're just getting it running.
	376	+ ORG CODEBG
	377	+
	378	+* ######>> screen 3 <<
	379	+*
	380	+***************************
	381	+ C O L D E N T R Y
	382	+***************************
	383	+ORIG NOP
	384	+* JMP CENT
	385	+ LBSR CENT
	386	+***************************
	387	+ W A R M E N T R Y
	388	+***************************
	389	+ NOP
	390	+* JMP WENT warm-start code, keeps current dictionary intact
	391	+ LBSR WENT warm-start code, keeps current dictionary intact
	392	+ SETDP IUPDP
	393	+
	394	+*
	395	+***** startup parmeters ************************
	396	+*
	397	+ FDB $6809,0000 cpu & revision
	398	+ FDB 0 topmost word in FORTH vocabulary
	399	+* BACKSP FDB $7F backspace character for editing
	400	+BACKSP FDB $08 backspace character for editing
	401	+UPINIT FDB UORIG initial user area
	402	+* UPINIT FDB UORIG initial user area
	403	+SINIT FDB ISP ; initial top of data stack
	404	+* SINIT FDB ORIG-$D0 initial top of data stack
	405	+RINIT FDB IRP ; initial top of return stack
	406	+* RINIT FDB ORIG-2 initial top of return stack
	407	+ FDB ITIB ; terminal input buffer
	408	+* FDB ORIG-$D0 terminal input buffer
	409	+ FDB 31 initial name field width
	410	+ FDB 0 initial warning mode (0 = no disc)
	411	+FENCIN FDB REND initial fence
	412	+DPINIT FDB REND cold start value for DICTPT
	413	+BUFINT FDB BUFBAS Start of the disk buffers area
	414	+VOCINT FDB FORTH+4*NATWID
	415	+COLINT FDB TIBSZ initial terminal carriage width
	416	+DELINT FDB 4 initial carriage return delay
	417	+****************************************************
	418	+*
	419	+ PAGE
	420	+*
	421	+* ######>> screen 13 <<
	422	+* These were of questionable use anyway,
	423	+* kept here now to satisfy the assembler and show hints.
	424	+* They're too much trouble to use with native subroutine call anyway.
	425	+* PULABX PULS A ; 24 cycles until 'NEXT'
	426	+* PULS B ;
	427	+* PULABX PULU A,B ; ?? cycles until 'NEXT'
	428	+* STABX STA 0,X 16 cycles until 'NEXT'
	429	+* STB 1,X
	430	+* STABX STD 0,X ; ?? cycles until 'NEXT'
	431	+ BRA NEXT
	432	+* GETX LDA 0,X 18 cycles until 'NEXT'
	433	+* LDB 1,X
	434	+* GETX LDD 0,X ?? cycles until 'NEXT'
	435	+* PUSHBA PSHS B ; 8 cycles until 'NEXT'
	436	+* PSHS A ;
	437	+* PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
	438	+
	439	+
	440	+*
	441	+* "NEXT" takes ?? cycles if TRACE is removed,
	442	+*
	443	+* and ?? cycles if trace is present and NOT tracing.
	444	+*
	445	+* = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
	446	+* =
	447	+* NEXT itself might just completely go away.
	448	+* About the only reason to keep it is to allowing executing a list
	449	+* which allows a cheap TRACE routine.
	450	+*
	451	+* NEXT is a loop which implements the Forth VM.
	452	+* It basically cycles through calling the code out of code lists,
	453	+* one at a time.
	454	+* Using a native CPU return for this uses a few extra cycles per call,
	455	+* compared to simply jumping to each definition and jumping back
	456	+* to the known beginning of the loop,
	457	+* but the loop itself is really only there for convenience.
	458	+*
	459	+* This implementation uses the native subroutine call,
	460	+* to break the wall between Forth code and non-Forth code.
	461	+*
	462	+* NEXT LDX IP
	463	+* LEAX 1,X ; pre-increment mode
	464	+* LEAX 1,X ;
	465	+* STX IP
	466	+NEXT ; IP is Y, push before using, pull before you come back here.
	467	+*
	468	+* NEXT2 LDX 0,X get W which points to CFA of word to be done
	469	+NEXT2 LDX ,Y++ get W which points to CFA of word to be done
	470	+* BSR DBGNAM
	471	+* BSR DBGREG
	472	+* But NEXT2 is too much trouble to use with subroutine threading anyway.
	473	+* NEXT3 STX W
	474	+NEXT3 ; W is X until you use X for something else. (TOS points back here.)
	475	+* But NEXT3 is too much trouble to use with subroutine threading anyway.
	476	+* LDX 0,X get VECT which points to executable code
	477	+* =
	478	+* The next instruction could be patched to JMP TRACE =
	479	+* if a TRACE routine is available: =
	480	+* =
	481	+* JMP 0,X
	482	+
	483	+ JSR [,X] ; Saving the postinc cycles,
	484	+* ; but X must be bumped NATWID to the parameters.
	485	+* NOP
	486	+* JMP TRACE ( an alternate for the above )
	487	+* BSR DBGREG ( an alternate for the above )
	488	+* In other words, with the call and the NOP,
	489	+* there is room to patch the call with a JMP to your TRACE
	490	+* routine, which you have to provide.
	491	+ BRA NEXT
	492	+*
	493	+DBGNAM PSHS CC,D,X,Y
	494	+ TST <TRACEM
	495	+ BEQ DBGNrt
	496	+ LEAX -3,X
	497	+DBGNlf LDB ,-X
	498	+ BPL DBGNlf
	499	+ LDY #$4C0
	500	+ LDB ,X+
	501	+DBGNlp LDB ,X+
	502	+ BMI DBGNll
	503	+ STB ,Y+
	504	+ BRA DBGNlp
	505	+DBGNll ANDB #$7F
	506	+ STB ,Y+
	507	+ LDB #$60
	508	+ BRA DBGNlt
	509	+DBGNlc STB ,Y+
	510	+DBGNlt CMPY #$4E0
	511	+ BLO DBGNlc
	512	+DBGNrt PULS CC,D,X,Y,PC
	513	+*
	514	+*
	515	+MKhxBh LSRB
	516	+ LSRB
	517	+ LSRB
	518	+ LSRB
	519	+MKhxBl ANDB #$0F
	520	+ ADDB #$30
	521	+ CMPB #$39
	522	+ BLS MKhxBx
	523	+ ADDB #$C7 ; ($40-$39)-$40
	524	+MKhxBx RTS
	525	+*
	526	+OUThxA EXG A,B
	527	+ BSR OUThxB
	528	+ EXG A,B
	529	+ RTS
	530	+*
	531	+OUThxD BSR OUThxA
	532	+OUThxB PSHS B
	533	+ BSR MKhxBh
	534	+ STB ,X+
	535	+ LDB ,S
	536	+ BSR MKhxBl
	537	+ STB ,X+
	538	+ PULS B,PC
	539	+*
	540	+DBGREG PSHS U,Y,X,DP,B,A,CC
	541	+ TST <TRACEM
	542	+ LBEQ DBGRrt
	543	+ LEAY DBGRLB,PCR
	544	+ LDX #$4E0
	545	+DBGRlp LDD ,Y++
	546	+ BEQ DBGRdn
	547	+ STD ,X++
	548	+ BRA DBGRlp
	549	+DBGRdn LDX #$500
	550	+ LDA 3,S ; DP
	551	+ LDB ,S ; CC
	552	+ BSR OUThxD
	553	+ LDB #$60
	554	+ STB ,X+
	555	+ LDD 3*NATWID+4,S ; PC:505
	556	+ BSR OUThxD
	557	+ LDB #$60
	558	+ STB ,X+
	559	+ TFR S,D ; 509
	560	+ ADDD #4*NATWID+4
	561	+ BSR OUThxD
	562	+ LDD 2*NATWID+4,S ; U:50E
	563	+ BSR OUThxD
	564	+ LDB #$60
	565	+ STB ,X+
	566	+ LDD 1*NATWID+4,S ; Y:513
	567	+ BSR OUThxD
	568	+ LDD 0*NATWID+4,S ; X at 517
	569	+ BSR OUThxD
	570	+ LDB #$60
	571	+ STB ,X+
	572	+ LDD 1,S ; D at 51C
	573	+ BSR OUThxD
	574	+ LDB #$60
	575	+ STB ,X+
	576	+ STB ,X+
	577	+ STB ,X+
	578	+ STB ,X+
	579	+ STB ,X+
	580	+ LDD [3*NATWID+4,S] ; PC
	581	+ BSR OUThxD
	582	+ LDB #$60
	583	+ STB ,X+
	584	+ LDD 4*NATWID+4,S ; S
	585	+ BSR OUThxD
	586	+ LDD [2*NATWID+4,S] ; U
	587	+ BSR OUThxD
	588	+ LDB #$60
	589	+ STB ,X+
	590	+ LDD [1*NATWID+4,S] ; Y
	591	+ LBSR OUThxD
	592	+ LDD [0*NATWID+4,S] ; X
	593	+ LBSR OUThxD
	594	+ LDB #$60
	595	+ STB ,X+
	596	+ STB ,X+
	597	+ STB ,X+
	598	+ STB ,X+
	599	+ STB ,X+
	600	+ LDB #0
	601	+ EXG B,DP
	602	+DBGRkl JSR [$A000]
	603	+ BEQ DBGRkl
	604	+ STD $43E
	605	+ EXG DP,B
	606	+ CMPA #$55 ; 'U'
	607	+ BEQ DBGRdU
	608	+ CMPA #$53 ; 'S'
	609	+ BEQ DBGRdS
	610	+ CMPA #$49 ; 'I'
	611	+ LBNE DBGRrt
	612	+DBGRin LDD <XTIB
	613	+ ADDD <XIN
	614	+ TFR D,Y
	615	+ LBSR OUThxD
	616	+ LDB #$3a ; ':'
	617	+ STB ,X+
	618	+ LDA <XCOLUM
	619	+DBGRip LDB ,Y+
	620	+ STB ,X+
	621	+ BEQ DBGRrt
	622	+DBGRit DECA
	623	+ BNE DBGRip
	624	+ BRA DBGRrt
	625	+DBGRdS TFR S,Y
	626	+ LDD ,Y++
	627	+ LBSR OUThxA
	628	+ LDA #$9F
	629	+ STA ,X+
	630	+ LBSR OUThxB
	631	+ LDD ,Y++
	632	+ LBSR OUThxA
	633	+ LDA #$9F
	634	+ STA ,X+
	635	+ LBSR OUThxB
	636	+ LDA #$58 ; X
	637	+ STA ,X+
	638	+ LDD ,Y++
	639	+ LBSR OUThxD
	640	+ LDA #$59 ; Y
	641	+ STA ,X+
	642	+ LDD ,Y++
	643	+ LBSR OUThxD
	644	+ LDA #$55 ; U
	645	+ STA ,X+
	646	+ LDD ,Y++
	647	+ LBSR OUThxD
	648	+ LDA #$50 ; PC
	649	+ STA ,X+
	650	+ LDD ,Y++
	651	+ LBSR OUThxD
	652	+ LDA #$53 ; Stack
	653	+ STA ,X+
	654	+ BRA DBGRst
	655	+DBGRsp LDD ,Y++
	656	+ LBSR OUThxD
	657	+ LDB #$60
	658	+ STB ,X+
	659	+DBGRst CMPY <XRZERO
	660	+ BLO DBGRsp
	661	+ LDB #$3a ; ':'
	662	+ STB ,X+
	663	+ LDB #$55
	664	+ STB ,X+
	665	+DBGRdU LDY 2*NATWID+4,S
	666	+ BRA DBGRut
	667	+DBGRup LDD ,Y++
	668	+ LBSR OUThxD
	669	+ LDB #$60
	670	+ STB ,X+
	671	+DBGRut CMPY <XSPZER
	672	+ BLO DBGRup
	673	+ LDB #$FF
	674	+ STB ,X+
	675	+DBGRrt PULS CC,A,B,DP,X,Y,U,PC
	676	+DBGRLB FCC 'DPCC PC S U Y X A B '
	677	+ FDB 0,0
	678	+
	679	+
	680	+*
	681	+* =
	682	+* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
	683	+
	684	+
	685	+ PAGE
	686	+*
	687	+* ======>> 1 <<
	688	+* ( --- n )
	689	+* Pushes the following natural width integer from the instruction stream
	690	+* as a literal, or immediate value.
	691	+*
	692	+* FDB {OP}
	693	+* FDB {OP}
	694	+* FDB LIT
	695	+* FDB LITERAL-TO-BE-PUSHED
	696	+* FDB {OP}
	697	+*
	698	+* In native processor code, there should be a better way, use that instead.
	699	+* More specifically, DO NOT CALL THIS from assembly language code.
	700	+* (Note that there is no compile-only flag in the fig model.)
	701	+*
	702	+* See (FIND), or PFIND , for layout of the header format.
	703	+*
	704	+ FCB $83
	705	+ FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
	706	+ FCB $D4 ; 'T'\|'\x80' ; character code for T, with high bit set.
	707	+ FDB 0 ; link of zero to terminate dictionary scan
	708	+LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
	709	+ LDD ,Y++
	710	+ PSHU A,B
	711	+ RTS
	712	+* LDX IP
	713	+* LEAX 1,X ;
	714	+* LEAX 1,X ;
	715	+* STX IP
	716	+* LDA 0,X
	717	+* LDB 1,X
	718	+* JMP PUSHBA
	719	+*
	720	+* ######>> screen 14 <<
	721	+* ======>> 2 <<
	722	+* ( --- n )
	723	+* Pushes the following byte from the instruction stream
	724	+* as a literal, or immediate value.
	725	+*
	726	+* FDB {OP}
	727	+* FDB {OP}
	728	+* FDB LIT8
	729	+* FCB LITERAL-TO-BE-PUSHED
	730	+* FDB {OP}
	731	+*
	732	+* If this is kept, it should have a header for TRACE to read.
	733	+* If the data bus is wider than a byte, you don't want to do this.
	734	+* Byte shaving like this is often counter-productive anyway.
	735	+* Changing the name to LIT8, hoping that will be more understandable.
	736	+* Also, see comments for LIT.
	737	+* (Note that there is no compile-only flag in the fig model.)
	738	+ FCB $84
	739	+ FCC 'LIT' ; 'LIT8' : NOTE: this is different from LITERAL
	740	+ FCB $B8
	741	+ FDB LIT-6
	742	+LIT8 FDB *+NATWID (this was an invisible word, with no header)
	743	+ LDB ,Y+ ; This also is meaningless in native code.
	744	+ CLRA
	745	+ PSHU A,B
	746	+ RTS
	747	+* LDX IP
	748	+* LEAX 1,X ;
	749	+* STX IP
	750	+* CLRA ;
	751	+* LDB 1,X
	752	+* JMP PUSHBA
	753	+*
	754	+* ( n off --- n )
	755	+* off is offset in video buffer area.
	756	+ FCB $87
	757	+ FCC 'SHOWTO' ; 'SHOWTOS'
	758	+ FCB $D3 ; 'S'
	759	+ FDB LIT8-7
	760	+SHOTOS FDB *+NATWID
	761	+ LDX #$400
	762	+ LDD ,U++
	763	+ LEAX D,X
	764	+ LDD ,U
	765	+ LBSR OUThxD
	766	+ RTS
	767	+*
	768	+ FCB $85
	769	+ FCC 'TROF' ; 'TROFF'
	770	+ FCB $C6 ; 'F'\|$80
	771	+ FDB SHOTOS-10
	772	+TROFF FDB *+NATWID
	773	+ CLR <TRACEM
	774	+ RTS
	775	+*
	776	+ FCB $84
	777	+ FCC 'TRO' ; 'TRON'
	778	+ FCB $CE ; 'N'\|$80
	779	+ FDB TROFF-8
	780	+TRON FDB *+NATWID
	781	+ INC <TRACEM
	782	+ RTS
	783	+*
	784	+* ======>> 3 <<
	785	+* ( adr --- )
	786	+* Jump to address on stack. Used by the "outer" interpreter to
	787	+* interactively invoke routines.
	788	+* Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
	789	+ FCB $87
	790	+ FCC 'EXECUT' ; 'EXECUTE'
	791	+ FCB $C5
	792	+ FDB TRON-7
	793	+EXEC FDB *+NATWID
	794	+ PULU X ; Gotta have W anyway, just in case.
	795	+ JMP [,X] ; Tail return.
	796	+* TFR S,X ; TSX :
	797	+* LDX 0,X get code field address (CFA)
	798	+* LEAS 1,S ; pop stack
	799	+* LEAS 1,S ;
	800	+* JMP NEXT3
	801	+*
	802	+* ######>> screen 15 <<
	803	+* ======>> 4 <<
	804	+* ( --- ) C
	805	+* Add the following word from the instruction stream to the
	806	+* instruction pointer (Y++). Causes a program branch in Forth code stream.
	807	+*
	808	+* In native processor code, there should be a better way, use that instead.
	809	+* More specifically, DO NOT CALL THIS from assembly language code.
	810	+* This is only for Forth code stream.
	811	+* Also, see comments for LIT.
	812	+ FCB $86
	813	+ FCC 'BRANC' ; 'BRANCH'
	814	+ FCB $C8
	815	+ FDB EXEC-10
	816	+BRAN FDB ZBYES ; Go steal code in ZBRANCH
	817	+
	818	+* Moving code around to optimize the branch taking case in 0BRANCH.
	819	+ZBNO LEAY NATWID,Y ; No branch.
	820	+ RTS
	821	+* ======>> 5 <<
	822	+* ( f --- ) C
	823	+* BRANCH if flag is zero.
	824	+*
	825	+* In native processor code, there should be a better way, use that instead.
	826	+* More specifically, DO NOT CALL THIS from assembly language code.
	827	+* This is only for Forth code stream.
	828	+* Also, see comments for LIT.
	829	+ FCB $87
	830	+ FCC '0BRANC' ; '0BRANCH'
	831	+ FCB $C8
	832	+ FDB BRAN-9
	833	+ZBRAN FDB *+NATWID
	834	+ LDD ,U++
	835	+ BNE ZBNO
	836	+ZBYES LDD ,Y++
	837	+ LEAY D,Y ; IP is postinc
	838	+ RTS
	839	+* PULS A ;
	840	+* PULS B ;
	841	+* PSHS B ; ** emulating ABA:
	842	+* ADDA ,S+ ;
	843	+* BNE ZBNO
	844	+* BCS ZBNO
	845	+* ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
	846	+* LDB 3,X
	847	+* LDA 2,X
	848	+* ADDB IP+1
	849	+* ADCA IP
	850	+* STB IP+1
	851	+* STA IP
	852	+* JMP NEXT
	853	+* ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
	854	+* LEAX 1,X ; jump over branch delta
	855	+* LEAX 1,X ;
	856	+* STX IP
	857	+* JMP NEXT
	858	+*
	859	+* ######>> screen 16 <<
	860	+* ======>> 6 <<
	861	+* ( --- ) ( limit index *** limit index+1) C
	862	+* ( limit index *** )
	863	+* Counting loop primitive. The counter and limit are the top two
	864	+* words on the return stack. If the updated index/counter does
	865	+* not exceed the limit, a branch occurs. If it does, the branch
	866	+* does not occur, and the index and limit are dropped from the
	867	+* return stack.
	868	+*
	869	+* In native processor code, there should be a better way, use that instead.
	870	+* More specifically, DO NOT CALL THIS from assembly language code.
	871	+* This is only for Forth code stream.
	872	+* Also, see comments for LIT.
	873	+ FCB $86
	874	+ FCC '(LOOP' ; '(LOOP)'
	875	+ FCB $A9
	876	+ FDB ZBRAN-10
	877	+XLOOP FDB *+NATWID
	878	+ LDD #1 ; Borrowing from BIF-6809.
	879	+XLOOPA ADDD NATWID,S ; Dodge the return address.
	880	+ STD NATWID,S
	881	+ SUBD 2*NATWID,S
	882	+ BMI ZBYES ; pseudo-signed-unsigned
	883	+XLOOPN LEAY NATWID,Y
	884	+ LDX ,S ; synthetic return
	885	+ LEAS 3*NATWID,S ; Clean up the index and limit.
	886	+ JMP ,X
	887	+* CLRA ;
	888	+* LDB #1 get set to increment counter by 1 (Clears N.)
	889	+* BRA XPLOP2 go steal other guy's code!
	890	+*
	891	+* ======>> 7 <<
	892	+* ( n --- ) ( limit index *** limit index+n ) C
	893	+* ( limit index *** )
	894	+* Loop with a variable increment. Terminates when the index
	895	+* crosses the boundary from one below the limit to the limit. A
	896	+* positive n will cause termination if the result index equals the
	897	+* limit. A negative n must cause the index to become less than
	898	+* the limit to cause loop termination.
	899	+*
	900	+* Note that the end conditions are not symmetric around zero.
	901	+*
	902	+* In native processor code, there should be a better way, use that instead.
	903	+* More specifically, DO NOT CALL THIS from assembly language code.
	904	+* This is only for Forth code stream.
	905	+* Also, see comments for LIT.
	906	+ FCB $87
	907	+ FCC '(+LOOP' ; '(+LOOP)'
	908	+ FCB $A9
	909	+ FDB XLOOP-9
	910	+XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
	911	+ LDD ,U++ ; inc val
	912	+ BPL XLOOPA ; Steal plain loop code for forward count.
	913	+ ADDD NATWID,S ; Dodge the return address
	914	+ STD NATWID,S
	915	+ SUBD 2*NATWID,S
	916	+ BPL ZBYES ; pseudo-signed-unsigned
	917	+ BRA XLOOPN ; This path might be less time-sensitive.
	918	+*
	919	+* This should work, but I want to use tested code.
	920	+* PULU A,B ; Get the increment.
	921	+* XPLOP2 PULS X ; Pre-clear the return stack.
	922	+* PSHU A ; Save the direction in high bit.
	923	+* ADDD ,S ; Count.
	924	+* STD ,S ; Update.
	925	+* SUBD NATWID,S ; Check limit.
	926	+**
	927	+** I think this should work:
	928	+* EORA ,U+ ; dir < 0 and (count - limit) >= 0
	929	+* BPL XPLONO ; or dir >= 0 and (count - limit) < 0
	930	+* LDD ,Y++
	931	+* LEAY D,Y ; IP is postinc
	932	+* JMP ,X
	933	+* XPLONO LEAS 2*NATWID,S
	934	+* JMP ,X ; synthetic return
	935	+*
	936	+* This definitely should work:
	937	+* TST ,U+ ; Get the sign
	938	+* BPL XPLOF ;
	939	+* CMPD NATWID,S
	940	+* BMI XPLONO
	941	+* XPLOYE LDD ,Y++
	942	+* LEAY D,Y ; IP is postinc
	943	+* JMP ,X
	944	+* XPLOF CMPD NATWID,S
	945	+* BMI XPLOYE
	946	+* XPLONO LEAS 2*NATWID,S
	947	+* JMP ,X ; synthetic return
	948	+*
	949	+* 6800 Probably could have used the exclusive-or method, too.:
	950	+* PULS A ; get increment
	951	+* PULS B ;
	952	+* XPLOP2 TSTA ;
	953	+* BPL XPLOF forward looping
	954	+* BSR XPLOPS
	955	+* ORCC #$01 ; SEC :
	956	+* SBCB 5,X
	957	+* SBCA 4,X
	958	+* BPL ZBYES
	959	+* BRA XPLONO fall through
	960	+*
	961	+* the subroutine :
	962	+* XPLOPS LDX RP
	963	+* ADDB 3,X add it to counter
	964	+* ADCA 2,X
	965	+* STB 3,X store new counter value
	966	+* STA 2,X
	967	+* RTS
	968	+*
	969	+* XPLOF BSR XPLOPS
	970	+* SUBB 5,X
	971	+* SBCA 4,X
	972	+* BMI ZBYES
	973	+*
	974	+* XPLONO LEAX 1,X ; done, don't branch back
	975	+* LEAX 1,X ;
	976	+* LEAX 1,X ;
	977	+* LEAX 1,X ;
	978	+* STX RP
	979	+* BRA ZBNO use ZBRAN to skip over unused delta
	980	+*
	981	+* ######>> screen 17 <<
	982	+* ======>> 8 <<
	983	+* ( limit index --- ) ( *** limit index )
	984	+* Move the loop parameters to the return stack. Synonym for D>R.
	985	+ FCB $84
	986	+ FCC '(DO' ; '(DO)'
	987	+ FCB $A9
	988	+ FDB XPLOOP-10
	989	+XDO FDB *+NATWID This is the RUNTIME DO, not the COMPILING DO
	990	+ LDX ,S ; Save the return address.
	991	+ PULU A,B
	992	+ PSHS A,B
	993	+ PULU A,B ; Maintain order.
	994	+ STD NATWID,S
	995	+ JMP ,X ; synthetic return
	996	+*
	997	+* LDX RP
	998	+* LEAX -1,X ;
	999	+* LEAX -1,X ;
	1000	+* LEAX -1,X ;
	1001	+* LEAX -1,X ;
	1002	+* STX RP
	1003	+* PULS A ;
	1004	+* PULS B ;
	1005	+* STA 2,X
	1006	+* STB 3,X
	1007	+* PULS A ;
	1008	+* PULS B ;
	1009	+* STA 4,X
	1010	+* STB 5,X
	1011	+* JMP NEXT
	1012	+*
	1013	+* ======>> 9 <<
	1014	+* ( --- index ) ( limit index *** limit index )
	1015	+* Copy the loop index from the return stack. Synonym for R.
	1016	+ FCB $81 I
	1017	+ FCB $C9
	1018	+ FDB XDO-7
	1019	+I FDB *+NATWID
	1020	+ LDD NATWID,S ; Dodge return address.
	1021	+ PSHU A,B
	1022	+ RTS
	1023	+* LDX RP
	1024	+* LEAX 1,X ;
	1025	+* LEAX 1,X ;
	1026	+* JMP GETX
	1027	+*
	1028	+* ######>> screen 18 <<
	1029	+* ======>> 10 <<
	1030	+* ( c base --- false )
	1031	+* ( c base --- n true )
	1032	+* Translate C in base, yielding a translation valid flag. If the
	1033	+* translation is not valid in the specified base, only the false
	1034	+* flag is returned.
	1035	+ FCB $85
	1036	+ FCC 'DIGI' ; 'DIGIT'
	1037	+ FCB $D4
	1038	+ FDB I-4
	1039	+DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
	1040	+ LDD NATWID,U ; Check the whole thing.
	1041	+ SUBD #$30 ; ascii zero
	1042	+ BMI DIGIT2 IF LESS THAN '0', ILLEGAL
	1043	+ CMPD #$A
	1044	+ BMI DIGIT0 IF '9' OR LESS
	1045	+ CMPD #$11
	1046	+ BMI DIGIT2 if less than 'A'
	1047	+ CMPD #$2B
	1048	+ BPL DIGIT2 if greater than 'Z'
	1049	+ SUBD #7 translate 'A' thru 'F'
	1050	+DIGIT0 CMPD ,U ; Check the base.
	1051	+ BPL DIGIT2 if not less than the base
	1052	+ STD NATWID,U ; Store converted digit. (High byte known zero.)
	1053	+ LDD #1 ; set valid flag
	1054	+DIGIT1 STD ,U ; store the flag
	1055	+ RTS NEXT
	1056	+DIGIT2 LDD #0 ; set not valid flag
	1057	+ LEAU NATWID,U ; pop base
	1058	+ BRA DIGIT1
	1059	+* TFR S,X ; TSX :
	1060	+* LDA 3,X
	1061	+* SUBA #$30 ascii zero
	1062	+* BMI DIGIT2 IF LESS THAN '0', ILLEGAL
	1063	+* CMPA #$A
	1064	+* BMI DIGIT0 IF '9' OR LESS
	1065	+* CMPA #$11
	1066	+* BMI DIGIT2 if less than 'A'
	1067	+* CMPA #$2B
	1068	+* BPL DIGIT2 if greater than 'Z'
	1069	+* SUBA #7 translate 'A' thru 'F'
	1070	+* DIGIT0 CMPA 1,X
	1071	+* BPL DIGIT2 if not less than the base
	1072	+* LDB #1 set flag
	1073	+* STA 3,X store digit
	1074	+* DIGIT1 STB 1,X store the flag
	1075	+* JMP NEXT
	1076	+* DIGIT2 CLRB ;
	1077	+* LEAS 1,S ;
	1078	+* LEAS 1,S ; pop bottom number
	1079	+* TFR S,X ; TSX :
	1080	+* STB 0,X make sure both bytes are 00
	1081	+* BRA DIGIT1
	1082	+*
	1083	+* ######>> screen 19 <<
	1084	+*
	1085	+* The word definition format in the dictionary:
	1086	+*
	1087	+* (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
	1088	+*
	1089	+* NFA (name field address):
	1090	+* char-count + $80 Length of symbol name, flagged with high bit set.
	1091	+* char 1 Characters of symbol name.
	1092	+* char 2
	1093	+* ...
	1094	+* char n + $80 symbol termination flag (char set < 128 code points)
	1095	+* LFA (link field address):
	1096	+* link high byte \___pointer to previous word in list
	1097	+* link low byte / -- Combined allocation/dictionary list. --
	1098	+* CFA (code field address):
	1099	+* CFA high byte \___pointer to native CPU machine code
	1100	+* CFA low byte / -- Consider this the characteristic code. --
	1101	+* PFA (parameter field address):
	1102	+* parameter fields -- Machine code for low-level native machine CPU code,
	1103	+* " instruction list for high-level Forth code,
	1104	+* " constant data for constants, pointers to per task variables,
	1105	+* " space for variables, for global variables, etc.
	1106	+*
	1107	+* In the case of native CPU machine code, the address at CFA will be PFA.
	1108	+
	1109	+* Definition attributes:
	1110	+FIMMED EQU $40 ; Immediate word flag.
	1111	+FSMUDG EQU $20 ; Smudged => definition not ready.
	1112	+CTMASK EQU ($FF&(^($80\|FIMMED))) ; For unmasking the length byte.
	1113	+* Note that the SMUDGE bit is not masked out.
	1114	+*
	1115	+* But we really want more (Thinking for a new model, need one more byte):
	1116	+* FCOMPI EQU $10 ; Compile-time-only.
	1117	+* FASSEM EQU $08 ; Assembly-language code only.
	1118	+* F4THLV EQU $04 ; Must not be called from assembly language code.
	1119	+* These would require some significant adjustments to the model.
	1120	+* We also want to put the low-level VM stuff in its own vocabulary.
	1121	+*
	1122	+* ======>> 11 <<
	1123	+* (FIND) ( name vocptr --- locptr length true )
	1124	+* ( name vocptr --- false )
	1125	+* Search vocabulary for a symbol called name.
	1126	+* name is a pointer to a high-bit bracket string with length head.
	1127	+* vocptr is a pointer to the NFA of the tail-end (LATEST) definition
	1128	+* in the vocabulary to be searched.
	1129	+* Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
	1130	+ FCB $86
	1131	+ FCC '(FIND' ; '(FIND)'
	1132	+ FCB $A9
	1133	+ FDB DIGIT-8
	1134	+PFIND FDB *+NATWID
	1135	+ PSHS Y ; Have to track two pointers.
	1136	+* Use the stack and registers instead of temp area N.
	1137	+PA0 EQU NATWID ; pointer to the length byte of name being searched against
	1138	+PD EQU 0 ; pointer to NFA of dict word being checked
	1139	+*
	1140	+* INC <TRACEM
	1141	+* LBSR DBGREG
	1142	+ LDX PD,U ; Start in on the vocabulary (NFA).
	1143	+PFNDLP LDY PA0,U ; Point to the name to check against.
	1144	+ LDB ,X+ ; get dict name length byte
	1145	+ TFR B,A ; Save it in case it matches.
	1146	+ ANDB #CTMASK
	1147	+* LBSR DBGREG
	1148	+ CMPB ,Y+ ; Compare lengths
	1149	+* LBSR DBGREG
	1150	+ BNE PFNDUN
	1151	+PFNDBR LDB ,X+
	1152	+ TSTB ; ; Is high bit of character in dictionary entry set?
	1153	+* LBSR DBGREG
	1154	+ BPL PFNDCH
	1155	+* LBSR DBGREG
	1156	+ ANDB #$7F ; Clear high bit from dictionary.
	1157	+ CMPB ,Y+ ; Compare "last" characters.
	1158	+* LBSR DBGREG
	1159	+ BEQ FOUND ; Matches even if dictionary actual length is shorter.
	1160	+PFNDLN LDX ,X++ ; Get previous link in vocabulary.
	1161	+* LBSR DBGREG
	1162	+ BNE PFNDLP ; Continue if link not=0
	1163	+*
	1164	+* not found :
	1165	+ LEAU NATWID,U ; Return only false flag.
	1166	+ LDD #0
	1167	+ STD ,U
	1168	+* LBSR DBGREG
	1169	+* DEC <TRACEM
	1170	+ PULS Y,PC
	1171	+*
	1172	+PFNDCH CMPB ,Y+ ; Compare characters.
	1173	+* LBSR DBGREG
	1174	+ BEQ PFNDBR
	1175	+PFNDUN
	1176	+PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
	1177	+* LBSR DBGREG
	1178	+ BPL PFNDSC
	1179	+* LBSR DBGREG
	1180	+ BRA PFNDLN
	1181	+*
	1182	+* found :
	1183	+*
	1184	+FOUND LEAX 2*NATWID,X
	1185	+* LBSR DBGREG
	1186	+ STX NATWID,U
	1187	+ TFR A,B
	1188	+ CLRA
	1189	+ STD ,U
	1190	+* LBSR DBGREG
	1191	+ LDB #1
	1192	+ PSHU A,B
	1193	+* LBSR DBGREG
	1194	+* DEC <TRACEM
	1195	+ PULS Y,PC
	1196	+*
	1197	+* 6800 model:
	1198	+* NOP ; Probably leftovers from a debugging session.
	1199	+* NOP
	1200	+* PD EQU N ptr to dict word being checked
	1201	+* PA0 EQU N+2
	1202	+* PA EQU N+4
	1203	+* PC EQU N+6
	1204	+* LDX #PD
	1205	+* LDB #4
	1206	+* PFIND0 PULS A ; loop to get arguments
	1207	+* STA 0,X
	1208	+* LEAX 1,X ;
	1209	+* DECB ;
	1210	+* BNE PFIND0
	1211	+*
	1212	+* LDX PD
	1213	+* PFNDLP LDB 0,X get count dict count
	1214	+* STB PC
	1215	+* ANDB #$3F
	1216	+* LEAX 1,X ;
	1217	+* STX PD update PD
	1218	+* LDX PA0
	1219	+* LDA 0,X get count from arg
	1220	+* LEAX 1,X ;
	1221	+* STX PA intialize PA
	1222	+* PSHS B ; ** emulating CBA:
	1223	+* CMPA ,S+ ; compare lengths
	1224	+* BNE PFNDUN
	1225	+* PFNDBR LDX PA
	1226	+* LDA 0,X
	1227	+* LEAX 1,X ;
	1228	+* STX PA
	1229	+* LDX PD
	1230	+* LDB 0,X
	1231	+* LEAX 1,X ;
	1232	+* STX PD
	1233	+* TSTB ; is dict entry neg. ?
	1234	+* BPL PFNDCH
	1235	+* ANDB #$7F clear sign
	1236	+* PSHS B ; ** emulating CBA:
	1237	+* CMPA ,S+ ;
	1238	+* BEQ FOUND
	1239	+* PFNDLN LDX 0,X get new link
	1240	+* BNE PFNDLP continue if link not=0
	1241	+*
	1242	+* not found :
	1243	+*
	1244	+* CLRA ;
	1245	+* CLRB ;
	1246	+* JMP PUSHBA
	1247	+* PFNDCH PSHS B ; ** emulating CBA:
	1248	+* CMPA ,S+ ;
	1249	+* BEQ PFNDBR
	1250	+* PFNDUN LDX PD
	1251	+* PFNDSC LDB 0,X scan forward to end of this name
	1252	+* LEAX 1,X ;
	1253	+* BPL PFNDSC
	1254	+* BRA PFNDLN
	1255	+*
	1256	+* found :
	1257	+*
	1258	+* FOUND LDA PD compute CFA
	1259	+* LDB PD+1
	1260	+* ADDB #4
	1261	+* ADCA #0
	1262	+* PSHS B ;
	1263	+* PSHS A ;
	1264	+* LDA PC
	1265	+* PSHS A ;
	1266	+* CLRA ;
	1267	+* PSHS A ;
	1268	+* LDB #1
	1269	+* JMP PUSHBA
	1270	+*
	1271	+* PSHS A ; Left over from a stray copy-paste, I guess.
	1272	+* CLRA ;
	1273	+* PSHS A ;
	1274	+* LDB #1
	1275	+* JMP PUSHBA
	1276	+*
	1277	+* ######>> screen 20 <<
	1278	+* ======>> 12 <<
	1279	+* ( buffer ch --- buffer symboloffset delimiteroffset scancount )
	1280	+* ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
	1281	+* ( buffer ch --- buffer nuloffset onepast scancount )
	1282	+* Scan buffer for a symbol delimited by ch or ASCII NUL,
	1283	+* return the length of the buffer region scanned,
	1284	+* the offset to the trailing delimiter,
	1285	+* and the offset of the first character of the symbol.
	1286	+* Leave the buffer on the stack.
	1287	+* Scancount is also offset to first character not yet looked at.
	1288	+* If no symbol in buffer, scancount and symboloffset point to NUL
	1289	+* and delimiteroffset points one beyond for some reason.
	1290	+* On trailing NUL, delimiteroffset == scancount.
	1291	+* (Buffer is the address of the buffer array to scan.)
	1292	+* (This is a bit too tricky, really.)
	1293	+ FCB $87
	1294	+ FCC 'ENCLOS' ; 'ENCLOSE'
	1295	+ FCB $C5
	1296	+ FDB PFIND-9
	1297	+ENCLOS FDB *+NATWID
	1298	+ LDA 1,U ; Delimiter character to match against in A.
	1299	+ LDX NATWID,U ; Buffer to scan in.
	1300	+ CLRB ; Initialize offset. (Buffer < 256 wide!)
	1301	+* Scan to a non-delimiter or a NUL
	1302	+ENCDEL TST B,X ; NUL ?
	1303	+ BEQ ENCNUL
	1304	+ CMPA B,X ; Delimiter?
	1305	+ BNE ENC1ST
	1306	+ INCB ; count character
	1307	+ BRA ENCDEL
	1308	+* Found first character. Save the offset.
	1309	+ENC1ST STB 1,U ; Found first non-delimiter character --
	1310	+ CLR ,U ; store the count, zero high byte.
	1311	+* Scan to a delimiter or a NUL
	1312	+ENCSYM TST B,X ; NUL ?
	1313	+ BEQ ENC0TR
	1314	+ CMPA B,X ; delimiter?
	1315	+ BEQ ENCEND
	1316	+ INCB
	1317	+ BRA ENCSYM
	1318	+* Found end of symbol. Push offset to delimiter found.
	1319	+ENCEND CLRA ; high byte -- buffer < 255 wide!
	1320	+ PSHU A,B ; Offset to seen delimiter.
	1321	+* Advance and push address of next character to check.
	1322	+ ADDD #1 ; In case offset was 255.
	1323	+ PSHU A,B
	1324	+ RTS
	1325	+* Found NUL before non-delimiter, therefore there is no word
	1326	+ENCNUL CLRA ; high byte -- buffer < 255 wide!
	1327	+ STD ,U ; offset to NUL.
	1328	+ ADDD #1 ; Point after NUL to allow (FIND) to match it.
	1329	+ PSHU A,B ;
	1330	+ SUBD #1 ; Next is not passed NUL.
	1331	+ PSHU A,B ; Stealing code will save only one byte.
	1332	+ RTS
	1333	+* Found NUL following the word instead of delimiter.
	1334	+ENC0TR
	1335	+* INC <TRACEM
	1336	+* LBSR DBGREG
	1337	+ CLRA
	1338	+ PSHU A,B ; Save offset to first after symbol (NUL)
	1339	+* LBSR DBGREG
	1340	+ PSHU A,B ; and count scanned.
	1341	+* LBSR DBGREG
	1342	+* DEC <TRACEM
	1343	+ RTS
	1344	+* NOTE :
	1345	+* FC means offset (bytes) to First Character of next word
	1346	+* EW " " to End of Word
	1347	+* NC " " to Next Character to start next enclose at
	1348	+* ENCLOS FDB *+NATWID
	1349	+* LEAS 1,S ;
	1350	+* PULS B ; now, get the low byte, for an 8-bit delimiter
	1351	+* TFR S,X ; TSX :
	1352	+* LDX 0,X
	1353	+* CLR N
	1354	+* * wait for a non-delimiter or a NUL
	1355	+* ENCDEL LDA 0,X
	1356	+* BEQ ENCNUL
	1357	+* PSHS B ; ** emulating CBA:
	1358	+* CMPA ,S+ ; CHECK FOR DELIM
	1359	+* BNE ENC1ST
	1360	+* LEAX 1,X ;
	1361	+* INC N
	1362	+* BRA ENCDEL
	1363	+* * found first character. Push FC
	1364	+* ENC1ST LDA N found first char.
	1365	+* PSHS A ;
	1366	+* CLRA ;
	1367	+* PSHS A ;
	1368	+* wait for a delimiter or a NUL
	1369	+* ENCSYM LDA 0,X
	1370	+* BEQ ENC0TR
	1371	+* PSHS B ; ** emulating CBA:
	1372	+* CMPA ,S+ ; ckech for delim.
	1373	+* BEQ ENCEND
	1374	+* LEAX 1,X ;
	1375	+* INC N
	1376	+* BRA ENCSYM
	1377	+* * found EW. Push it
	1378	+* ENCEND LDB N
	1379	+* CLRA ;
	1380	+* PSHS B ;
	1381	+* PSHS A ;
	1382	+* * advance and push NC
	1383	+* INCB ;
	1384	+* JMP PUSHBA
	1385	+* found NUL before non-delimiter, therefore there is no word
	1386	+* ENCNUL LDB N found NUL
	1387	+* PSHS B ;
	1388	+* PSHS A ;
	1389	+* INCB ;
	1390	+* BRA ENC0TR+2 ; ******** POTENTIAL BUG HERE *****
	1391	+* ****** Should use labels in case opcodes change! ******
	1392	+* found NUL following the word instead of SPACE
	1393	+* ENC0TR LDB N
	1394	+* PSHS B ; save EW
	1395	+* PSHS A ;
	1396	+* ENCL8 LDB N save NC
	1397	+* JMP PUSHBA
	1398	+
	1399	+ PAGE
	1400	+*
	1401	+* ######>> screen 21 <<
	1402	+* The next 4 words call system dependant I/O routines
	1403	+* which are listed after word "-->" ( lable: "arrow" )
	1404	+* in the dictionary.
	1405	+*
	1406	+* ======>> 13 <<
	1407	+* ( c --- )
	1408	+* Write c to the output device (screen or printer).
	1409	+* ROM Uses the ECB device number at address $6F,
	1410	+* -2 is printer, 0 is screen.
	1411	+ FCB $84
	1412	+ FCC 'EMI' ; 'EMIT'
	1413	+ FCB $D4
	1414	+ FDB ENCLOS-10
	1415	+EMIT FDB *+NATWID
	1416	+ PULU D
	1417	+ LBSR PEMIT ; PEMIT expects the character in D.
	1418	+ INC <XOUT+1
	1419	+ BNE EMITDN
	1420	+ INC <XOUT
	1421	+EMITDN RTS
	1422	+* PULS A ;
	1423	+* PULS A ;
	1424	+* JSR PEMIT
	1425	+* LDX UP
	1426	+* INC XOUT+1-UORIG,X
	1427	+* BNE *+4 ;
	1428	+* **WARNING** HARD OFFSET: +4 ***
	1429	+* INC XOUT-UORIG,X
	1430	+* JMP NEXT
	1431	+*
	1432	+* ======>> 14 <<
	1433	+* ( --- c )
	1434	+* ( --- BREAK )
	1435	+* Wait for a key from the keyboard.
	1436	+* If the key is BREAK, set the high byte (result $FF03).
	1437	+ FCB $83
	1438	+ FCC 'KE' ; 'KEY'
	1439	+ FCB $D9
	1440	+ FDB EMIT-7
	1441	+KEY FDB *+NATWID
	1442	+ LBSR PKEY ; PKEY leaves the key/break code in D.
	1443	+ PSHU D
	1444	+ RTS
	1445	+* JSR PKEY
	1446	+* PSHS A ;
	1447	+* CLRA ;
	1448	+* PSHS A ;
	1449	+* JMP NEXT
	1450	+*
	1451	+* ======>> 15 <<
	1452	+* ( --- f )
	1453	+* Scan keyboard, but do not wait.
	1454	+* Return 0 if no key,
	1455	+* BREAK ($ff03) if BREAK is pressed,
	1456	+* or key currently pressed.
	1457	+ FCB $89
	1458	+ FCC '?TERMINA' ; '?TERMINAL'
	1459	+ FCB $CC
	1460	+ FDB KEY-6
	1461	+QTERM FDB *+NATWID
	1462	+ LBSR PQTER ; PQTER leaves the flag/key in D.
	1463	+ PSHU D
	1464	+ RTS
	1465	+* JSR PQTER
	1466	+* CLRB ;
	1467	+* JMP PUSHBA stack the flag
	1468	+*
	1469	+* ======>> 16 <<
	1470	+* ( --- )
	1471	+* EMIT a Carriage Return (ASCII CR).
	1472	+ FCB $82
	1473	+ FCC 'C' ; 'CR'
	1474	+ FCB $D2
	1475	+ FDB QTERM-12
	1476	+CR FDB *+NATWID
	1477	+ LBRA PCR ; Nothing really to do here.
	1478	+* JSR PCR
	1479	+* JMP NEXT
	1480	+*
	1481	+* ######>> screen 22 <<
	1482	+* ======>> 17 <<
	1483	+* ( source target count --- )
	1484	+* Copy/move count bytes from source to target.
	1485	+* Moves ascending addresses,
	1486	+* so that overlapping only works if the source is above the destination.
	1487	+ FCB $85
	1488	+ FCC 'CMOV' ; 'CMOVE' : source, destination, count
	1489	+ FCB $C5
	1490	+ FDB CR-5
	1491	+CMOVE FDB *+NATWID
	1492	+* Another way ; takes ( 42+17count+9(count/256) cycles )
	1493	+ LDD #0 ; #3~3
	1494	+ SUBD ,U++ ; #2~9 ; invert the count
	1495	+ PSHS A,Y ; #2~8
	1496	+ PULU X,Y ; #2~9
	1497	+ BEQ CMOVEX ; #2~3
	1498	+CMOVEL
	1499	+ LDA ,Y+ ; #2~6
	1500	+ STA ,X+ ; #2~6
	1501	+ INCB ; #1~2
	1502	+ BNE CMOVEL ; #2~3
	1503	+ INC ,S ; #2~6
	1504	+ BNE CMOVEL ; #2~3
	1505	+CMOVEX PULS A,Y,PC ; #2~10
	1506	+* PSHS Y ;
	1507	+* INC <TRACEM
	1508	+* LBSR DBGREG
	1509	+* LDX 1*NATWID,U
	1510	+* LDY 2*NATWID,U
	1511	+* BRA CMOVLE ;
	1512	+* CMOVLP
	1513	+* LBSR DBGREG
	1514	+* LDA ,Y+
	1515	+* STA ,X+
	1516	+* LBSR DBGREG
	1517	+* CMOVLE
	1518	+* LDD ,U
	1519	+* SUBD #1
	1520	+* STD ,U
	1521	+* BCC CMOVLP
	1522	+* LEAU 3*NATWID,U
	1523	+* DEC <TRACEM
	1524	+* PULS Y,PC
	1525	+* One way: ; takes ( 37+17count+9(count/256) cycles )
	1526	+* PSHS Y ; #2~7 ; Gotta have our pointers.
	1527	+* INC <TRACEM
	1528	+* LBSR DBGREG
	1529	+* PULU D,X,Y ; #2~11
	1530	+* PSHS A ; #2~6 ; Gotta have our pointers.
	1531	+* BRA CMOVLE ; #2~3
	1532	+* CMOVLP
	1533	+* LBSR DBGREG
	1534	+* LDA ,Y+ ; #2~6
	1535	+* STA ,X+ ; #2~6
	1536	+* LBSR DBGREG
	1537	+* CMOVLE
	1538	+* SUBB #1 ; #2~2
	1539	+* BCC CMOVLP ; #2~3
	1540	+* DEC ,S ; #2=6
	1541	+* BPL CMOVLP ; #2~3 ; If this actually works, it is limited to 32k here.
	1542	+* DEC <TRACEM
	1543	+* PULS A,Y,PC ; #2~10
	1544	+* Yet another way ; takes ( 37+29*count cycles )
	1545	+* PSHS Y ; #2~7
	1546	+* LDX NATWID,U ; #2~6
	1547	+* LDY NATWID,U ; #3~7
	1548	+* BRA CMOVLE ; #2~3
	1549	+* CMOVLP
	1550	+* LDA ,Y+ ; #2~6
	1551	+* STA ,X+ ; #2~6
	1552	+* CMOVLE
	1553	+* LDD ,U ; #2~5
	1554	+* SUBD #1 ; #3~4
	1555	+* STD ,U ; #2~5
	1556	+* BPL CMOVLP ; #2~3
	1557	+* LEAU 3*NATWID,U ; #2~5
	1558	+* PULS Y,PC ; #2~9
	1559	+* Yet another way ; takes ( 44+24odd+33count/2 cycles )
	1560	+* PSHS Y ; #2~7
	1561	+* LDX NATWID,U ; #2~6
	1562	+* LDY 2*NATWID,U ; #3~7
	1563	+* LDD ,U ; #2~5
	1564	+* BITB #1 ; #2~2
	1565	+* BEQ CMOVLE ; #2~3
	1566	+* SUBD #1 ; #3~4
	1567	+* STD ,U ; #2~5
	1568	+* LDA ,Y+ ; #2~6
	1569	+* STA ,X+ ; #2~6
	1570	+* BRA CMOVLE ; #2~3
	1571	+* CMOVLP
	1572	+* LDD ,Y++ ; #2~8
	1573	+* STD ,X++ ; #2~8
	1574	+* CMOVLI
	1575	+* LDD ,U ; #2~5
	1576	+* CMOVLE
	1577	+* SUBD #2 ; #3~4
	1578	+* STD ,U ; #2~5
	1579	+* BPL CMOVLP ; #2~3
	1580	+* LEAU 3*NATWID,U ; #2~5
	1581	+* PULS Y,PC ; #2~9
	1582	+* From the 6800 model:
	1583	+* CMOVE FDB +2 takes ( 43+47count cycles ) on 6800
	1584	+* LDX #N
	1585	+* LDB #6
	1586	+* CMOV1 PULS A ;
	1587	+* STA 0,X move parameters to scratch area
	1588	+* LEAX 1,X ;
	1589	+* DECB ;
	1590	+* BNE CMOV1
	1591	+* CMOV2 LDA N
	1592	+* LDB N+1
	1593	+* SUBB #1
	1594	+* SBCA #0
	1595	+* STA N
	1596	+* STB N+1
	1597	+* BCS CMOV3
	1598	+* LDX N+4
	1599	+* LDA 0,X
	1600	+* LEAX 1,X ;
	1601	+* STX N+4
	1602	+* LDX N+2
	1603	+* STA 0,X
	1604	+* LEAX 1,X ;
	1605	+* STX N+2
	1606	+* BRA CMOV2
	1607	+* CMOV3 JMP NEXT
	1608	+*
	1609	+* ######>> screen 23 <<
	1610	+* ======>> 18 <<
	1611	+* ( u1 u2 --- ud )
	1612	+* Multiplies the top two unsigned integers,
	1613	+* yielding a double integer product.
	1614	+ FCB $82
	1615	+ FCC 'U' ; 'U*'
	1616	+ FCB $AA
	1617	+ FDB CMOVE-8
	1618	+USTAR FDB *+NATWID
	1619	+ LEAU -2*NATWID,U
	1620	+ LDA 2*NATWID+1,U ; least
	1621	+ LDB 3*NATWID+1,U
	1622	+ MUL
	1623	+ STD NATWID,U
	1624	+ LDA 2*NATWID,U ; most
	1625	+ LDB 3*NATWID,U
	1626	+ MUL
	1627	+ STD ,U
	1628	+ LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi)
	1629	+ MUL
	1630	+ ADDD 1,U
	1631	+ BCC USTAR3
	1632	+ INC ,U
	1633	+USTAR3 STD 1,U
	1634	+ LDA 2*NATWID,U ; second inner (u2 hi)
	1635	+ LDB 3*NATWID,U ; (u1 lo)
	1636	+ MUL
	1637	+ ADDD 1,U
	1638	+ BCC USTAR4
	1639	+ INC ,U
	1640	+USTAR4 STD 1,U
	1641	+ PULU D,X
	1642	+ STD ,U
	1643	+ STX NATWID,U
	1644	+ RTS
	1645	+*
	1646	+* from 6800 model:
	1647	+* BSR USTARS
	1648	+* LEAS 1,S ;
	1649	+* LEAS 1,S ;
	1650	+* JMP PUSHBA
	1651	+*
	1652	+* The following is a subroutine which
	1653	+* multiplies top 2 words on stack,
	1654	+* leaving 32-bit result: high order word in A,B
	1655	+* low order word in 2nd word of stack.
	1656	+*
	1657	+* USTARS LDA #16 bits/word counter
	1658	+* PSHS A ;
	1659	+* CLRA ;
	1660	+* CLRB ;
	1661	+* TFR S,X ; TSX :
	1662	+* USTAR2 ROR 5,X shift multiplier
	1663	+* ROR 6,X
	1664	+* DEC 0,X done?
	1665	+* BMI USTAR4
	1666	+* BCC USTAR3
	1667	+* ADDB 4,X
	1668	+* ADCA 3,X
	1669	+* USTAR3 RORA ;
	1670	+* RORB ; shift result
	1671	+* BRA USTAR2
	1672	+* USTAR4 LEAS 1,S ; dump counter
	1673	+* RTS
	1674	+*
	1675	+* ######>> screen 24 <<
	1676	+* ======>> 19 <<
	1677	+* ( ud u --- uremainder uquotient )
	1678	+* Divides the top unsigned integer
	1679	+* into the second and third words on the stack
	1680	+* as a single unsigned double integer,
	1681	+* leaving the remainder and quotient (quotient on top)
	1682	+* as unsigned integers.
	1683	+*
	1684	+* The smaller the divisor, the more likely dropping the high word
	1685	+* of the quotient loses significant bits. See M/MOD .
	1686	+*
	1687	+ FCB $82
	1688	+ FCC 'U' ; 'U/'
	1689	+ FCB $AF
	1690	+ FDB USTAR-5
	1691	+USLASH FDB *+NATWID
	1692	+ LDA #17 ; bit ct
	1693	+ PSHS A
	1694	+ LDD NATWID,U ; dividend
	1695	+USLDIV CMPD ,U ; divisor
	1696	+ BHS USLSUB
	1697	+ ANDCC #~1 ; carry clear
	1698	+ BRA USLBIT
	1699	+USLSUB SUBD ,U
	1700	+ ORCC #1 ; quotient, (carry set)
	1701	+USLBIT ROL 2*NATWID+1,U ; save it
	1702	+ ROL 2*NATWID,U
	1703	+ DEC ,S ; more bits?
	1704	+ BEQ USLR
	1705	+ ROLB ; remainder
	1706	+ ROLA
	1707	+ BCC USLDIV
	1708	+ BRA USLSUB
	1709	+USLR LEAU NATWID,U
	1710	+ LDX NATWID,U
	1711	+ STD NATWID,U
	1712	+ STX ,U
	1713	+ PULS A,PC ; Avoiding a LEAS 1,S by discarding A.
	1714	+*
	1715	+* from 6800 model:
	1716	+* LDA #17
	1717	+* PSHS A ;
	1718	+* TFR S,X ; TSX :
	1719	+* LDA 3,X
	1720	+* LDB 4,X
	1721	+* USL1 CMPA 1,X
	1722	+* BHI USL3
	1723	+* BCS USL2
	1724	+* CMPB 2,X
	1725	+* BCC USL3
	1726	+* USL2 ANDCC #~$01 ; CLC :
	1727	+* BRA USL4
	1728	+* USL3 SUBB 2,X
	1729	+* SBCA 1,X
	1730	+* ORCC #$01 ; SEC :
	1731	+* USL4 ROL 6,X
	1732	+* ROL 5,X
	1733	+* DEC 0,X
	1734	+* BEQ USL5
	1735	+* ROLB ;
	1736	+* ROLA ;
	1737	+* BCC USL1
	1738	+* BRA USL3
	1739	+* USL5 LEAS 1,S ;
	1740	+* LEAS 1,S ;
	1741	+* LEAS 1,S ;
	1742	+* LEAS 1,S ;
	1743	+* LEAS 1,S ;
	1744	+* JMP SWAP+4 reverse quotient & remainder
	1745	+*
	1746	+* ######>> screen 25 <<
	1747	+* ======>> 20 <<
	1748	+* ( n1 n2 --- n )
	1749	+* Bitwise and the top two integers.
	1750	+ FCB $83
	1751	+ FCC 'AN' ; 'AND'
	1752	+ FCB $C4
	1753	+ FDB USLASH-5
	1754	+AND FDB *+NATWID
	1755	+ PULU A,B
	1756	+ ANDB 1,U
	1757	+ ANDA ,U
	1758	+ STD ,U
	1759	+ RTS
	1760	+* PULS A ;
	1761	+* PULS B ;
	1762	+* TFR S,X ; TSX :
	1763	+* ANDB 1,X
	1764	+* ANDA 0,X
	1765	+* JMP STABX
	1766	+*
	1767	+* ======>> 21 <<
	1768	+* ( n1 n2 --- n )
	1769	+* Bitwise or the top two integers.
	1770	+ FCB $82
	1771	+ FCC 'O' ; 'OR'
	1772	+ FCB $D2
	1773	+ FDB AND-6
	1774	+OR FDB *+NATWID
	1775	+ PULU A,B
	1776	+ ORB 1,U
	1777	+ ORA ,U
	1778	+ STD ,U
	1779	+ RTS
	1780	+* PULS A ;
	1781	+* PULS B ;
	1782	+* TFR S,X ; TSX :
	1783	+* ORB 1,X
	1784	+* ORA 0,X
	1785	+* JMP STABX
	1786	+*
	1787	+* ======>> 22 <<
	1788	+* ( n1 n2 --- n )
	1789	+* Bitwise exclusive or the top two integers.
	1790	+ FCB $83
	1791	+ FCC 'XO' ; 'XOR'
	1792	+ FCB $D2
	1793	+ FDB OR-5
	1794	+XOR FDB *+NATWID
	1795	+ PULU A,B
	1796	+ EORB 1,U
	1797	+ EORA ,U
	1798	+ STD ,U
	1799	+ RTS
	1800	+* PULS A ;
	1801	+* PULS B ;
	1802	+* TFR S,X ; TSX :
	1803	+* EORB 1,X
	1804	+* EORA 0,X
	1805	+* JMP STABX
	1806	+*
	1807	+* ######>> screen 26 <<
	1808	+* ======>> 23 <<
	1809	+* ( --- adr )
	1810	+* Fetch the parameter stack pointer (before it is pushed).
	1811	+* This points at whatever was on the top of stack before.
	1812	+ FCB $83
	1813	+ FCC 'SP' ; 'SP@'
	1814	+ FCB $C0
	1815	+ FDB XOR-6
	1816	+SPAT FDB *+NATWID
	1817	+ TFR U,X
	1818	+ PSHU X
	1819	+ RTS
	1820	+* TFR S,X ; TSX :
	1821	+* STX N scratch area
	1822	+* LDX #N
	1823	+* JMP GETX
	1824	+*
	1825	+* ======>> 24 <<
	1826	+* ( whatever --- nothing )
	1827	+* Initialize the parameter stack pointer from the USER variable S0.
	1828	+* Effectively clears the stack.
	1829	+ FCB $83
	1830	+ FCC 'SP' ; 'SP!'
	1831	+ FCB $A1
	1832	+ FDB SPAT-6
	1833	+SPSTOR FDB *+NATWID
	1834	+ LDU <XSPZER
	1835	+ RTS
	1836	+* LDX UP
	1837	+* LDX XSPZER-UORIG,X
	1838	+* TFR X,S ; TXS : watch it ! X and S are not equal on 6800.
	1839	+* JMP NEXT
	1840	+* ======>> 25 <<
	1841	+* ( whatever *** nothing )
	1842	+* Initialize the return stack pointer from the initialization table
	1843	+* instead of the user variable R0, for some reason.
	1844	+* Quite possibly, this should be from R0.
	1845	+* Effectively aborts all in process definitions, except the active one.
	1846	+* An emergency measure, to be sure.
	1847	+* The routine that calls this must never execute a return.
	1848	+* So this should never be executed from the terminal, I guess.
	1849	+* This is another that should be compile-time only, and in a separate vocabulary.
	1850	+ FCB $83
	1851	+ FCC 'RP' ; 'RP!'
	1852	+ FCB $A1
	1853	+ FDB SPSTOR-6
	1854	+RPSTOR FDB *+NATWID
	1855	+ PULS X ; But this guy has to return to his caller.
	1856	+ LDS RINIT
	1857	+ JMP ,X
	1858	+* LDX RINIT initialize from rom constant
	1859	+* STX RP
	1860	+* JMP NEXT
	1861	+*
	1862	+* ======>> 26 <<
	1863	+* ( ip *** )
	1864	+* Pop IP from return stack (return from high-level definition).
	1865	+* Can be used in a screen to force interpretion to terminate.
	1866	+* Must not be executed when temporaries are saved on top of the return stack.
	1867	+ FCB $82
	1868	+ FCC ';' ; ';S'
	1869	+ FCB $D3
	1870	+ FDB RPSTOR-6
	1871	+SEMIS FDB *+NATWID
	1872	+ PULS D,Y ; return address in D, and saved IP in Y.
	1873	+ TFR D,PC ; Synthetic return.
	1874	+*
	1875	+* Form 6800 model:
	1876	+* LDX RP
	1877	+* LEAX 1,X ;
	1878	+* LEAX 1,X ;
	1879	+* STX RP
	1880	+* LDX 0,X get address we have just finished.
	1881	+* JMP NEXT+2 increment the return address & do next word
	1882	+*
	1883	+* ######>> screen 27 <<
	1884	+* ======>> 27 <<
	1885	+* ( limit index *** index index )
	1886	+* Force the terminating condition for the innermost loop by
	1887	+* copying its index to its limit.
	1888	+* Termination is postponed until the next
	1889	+* LOOP or +LOOP instruction is executed.
	1890	+* The index remains available for use until
	1891	+* the LOOP or +LOOP instruction is encountered.
	1892	+* Note that the assumption is that the current count is the correct count
	1893	+* to end at, rather than pushing the count to the final count.
	1894	+ FCB $85
	1895	+ FCC 'LEAV' ; 'LEAVE'
	1896	+ FCB $C5
	1897	+ FDB SEMIS-5
	1898	+LEAVE FDB *+NATWID
	1899	+ LDD NATWID,S ; Dodge the return address.
	1900	+ STD 2*NATWID,S
	1901	+ RTS
	1902	+* LDX RP
	1903	+* LDA 2,X
	1904	+* LDB 3,X
	1905	+* STA 4,X
	1906	+* STB 5,X
	1907	+* JMP NEXT
	1908	+*
	1909	+* ======>> 28 <<
	1910	+* ( n --- )
	1911	+* ( *** n )
	1912	+* Move top of parameter stack to top of return stack.
	1913	+ FCB $82
	1914	+ FCC '>' ; '>R'
	1915	+ FCB $D2
	1916	+ FDB LEAVE-8
	1917	+TOR FDB *+NATWID
	1918	+ PULU A,B
	1919	+ LDX ,S
	1920	+ STD ,S ; Put it where the return address was.
	1921	+ JMP ,X
	1922	+* LDX RP
	1923	+* LEAX -1,X ;
	1924	+* LEAX -1,X ;
	1925	+* STX RP
	1926	+* PULS A ;
	1927	+* PULS B ;
	1928	+* STA 2,X
	1929	+* STB 3,X
	1930	+* JMP NEXT
	1931	+*
	1932	+* ======>> 29 <<
	1933	+* ( --- n )
	1934	+* ( n *** )
	1935	+* Move top of return stack to top of parameter stack.
	1936	+ FCB $82
	1937	+ FCC 'R' ; 'R>'
	1938	+ FCB $BE
	1939	+ FDB TOR-5
	1940	+FROMR FDB *+NATWID
	1941	+ PULS D,X
	1942	+ PSHU X
	1943	+ TFR D,PC
	1944	+* LDX RP
	1945	+* LDA 2,X
	1946	+* LDB 3,X
	1947	+* LEAX 1,X ;
	1948	+* LEAX 1,X ;
	1949	+* STX RP
	1950	+* JMP PUSHBA
	1951	+*
	1952	+* ======>> 30 <<
	1953	+* ( --- n )
	1954	+* ( n *** n )
	1955	+* Copy the top of return stack to top of parameter stack.
	1956	+* A synonym for I.
	1957	+ FCB $81 R
	1958	+ FCB $D2
	1959	+ FDB FROMR-5
	1960	+R FDB I+NATWID
	1961	+
	1962	+* LDX RP
	1963	+* LEAX 1,X ;
	1964	+* LEAX 1,X ;
	1965	+* JMP GETX
	1966	+*
	1967	+* ######>> screen 28 <<
	1968	+* ======>> 31 <<
	1969	+* ( n --- ~n )
	1970	+* Logically invert top of stack;
	1971	+* or flag true if top is zero, otherwise false.
	1972	+ FCB $83
	1973	+ FCC 'NO' ; 'NOT'
	1974	+ FCB $D4
	1975	+ FDB R-4
	1976	+LNOT FDB *+NATWID
	1977	+ COM 1,U
	1978	+ COM ,U
	1979	+ RTS
	1980	+* ( n --- n=0 )
	1981	+* Logically invert top of stack;
	1982	+* or flag true if top is zero, otherwise false.
	1983	+ FCB $82
	1984	+ FCC '0' ; '0='
	1985	+ FCB $BD
	1986	+ FDB LNOT-6
	1987	+ZEQU FDB *+NATWID
	1988	+ LDD #0
	1989	+ LDX ,U
	1990	+ BNE ZEQUF
	1991	+ INCB ; 1 is true
	1992	+ZEQUF STD ,U
	1993	+ RTS
	1994	+* TFR S,X ; TSX :
	1995	+* CLRA ;
	1996	+* CLRB ;
	1997	+* LDX 0,X
	1998	+* BNE ZEQU2
	1999	+* INCB ;
	2000	+*ZEQU2 TFR S,X ; TSX :
	2001	+* JMP STABX
	2002	+*
	2003	+* ======>> 32 <<
	2004	+* ( n --- n<0 )
	2005	+* Flag true if top is negative (MSbit set), otherwise false.
	2006	+ FCB $82
	2007	+ FCC '0' ; '0<'
	2008	+ FCB $BC
	2009	+ FDB ZEQU-5
	2010	+ZLESS FDB *+NATWID
	2011	+ LDD #0
	2012	+ TST ,U
	2013	+ BPL ZLESSF
	2014	+ INCB
	2015	+ZLESSF STD ,U
	2016	+ RTS
	2017	+* TFR S,X ; TSX :
	2018	+* LDA #$80 check the sign bit
	2019	+* ANDA 0,X
	2020	+* BEQ ZLESS2
	2021	+* CLRA ; if neg.
	2022	+* LDB #1
	2023	+* JMP STABX
	2024	+* ZLESS2 CLRB ;
	2025	+* JMP STABX
	2026	+*
	2027	+* ######>> screen 29 <<
	2028	+* ======>> 33 <<
	2029	+* ( n1 n2 --- n1+n2 )
	2030	+* Add top two words.
	2031	+ FCB $81 '+'
	2032	+ FCB $AB
	2033	+ FDB ZLESS-5
	2034	+PLUS FDB *+NATWID
	2035	+ PULU A,B ; #2~7
	2036	+ ADDD ,U ; #2~6
	2037	+ STD ,U ; #2~5
	2038	+ RTS ; #1~5 =#7~23
	2039	+* PULS A ;
	2040	+* PULS B ;
	2041	+* TFR S,X ; TSX :
	2042	+* ADDB 1,X
	2043	+* ADCA 0,X
	2044	+* JMP STABX
	2045	+*
	2046	+* ======>> 34 <<
	2047	+* ( d1 d2 --- d1+d2 )
	2048	+* Add top two double integers.
	2049	+ FCB $82
	2050	+ FCC 'D' ; 'D+'
	2051	+ FCB $AB
	2052	+ FDB PLUS-4
	2053	+DPLUS FDB *+NATWID
	2054	+ LDD 3*NATWID,U
	2055	+ ADDD NATWID,U
	2056	+ STD 3*NATWID,U
	2057	+ LDD 2*NATWID,U
	2058	+ ADCB 1,U
	2059	+ ADCA ,U
	2060	+ LEAU 2*NATWID,U
	2061	+ STD ,U
	2062	+ RTS
	2063	+* TFR S,X ; TSX :
	2064	+* ANDCC #~$01 ; CLC :
	2065	+* LDB #4
	2066	+* DPLUS2 LDA 3,X
	2067	+* ADCA 7,X
	2068	+* STA 7,X
	2069	+* LEAX -1,X ;
	2070	+* DECB ;
	2071	+* BNE DPLUS2
	2072	+* LEAS 1,S ;
	2073	+* LEAS 1,S ;
	2074	+* LEAS 1,S ;
	2075	+* LEAS 1,S ;
	2076	+* JMP NEXT
	2077	+*
	2078	+* ======>> 35 <<
	2079	+* ( n --- -n )
	2080	+* Negate (two's complement) top of stack.
	2081	+ FCB $85
	2082	+ FCC 'MINU' ; 'MINUS'
	2083	+ FCB $D3
	2084	+ FDB DPLUS-5
	2085	+MINUS FDB *+NATWID
	2086	+ LDD #0 ; #3~3
	2087	+ SUBD ,U ; #2~5
	2088	+ STD ,U ; #2~5
	2089	+ RTS ; #1~5 = #8~18
	2090	+*
	2091	+* from 6800 model code:
	2092	+* TFR S,X ; TSX :
	2093	+* NEG 1,X
	2094	+* BCC MINUS2
	2095	+* NEG 0,X
	2096	+* BRA MINUS3
	2097	+* MINUS2 COM 0,X
	2098	+* MINUS3 JMP NEXT
	2099	+*
	2100	+* ======>> 36 <<
	2101	+* ( d --- -d )
	2102	+* Negate (two's complement) top two words on stack as a double integer.
	2103	+ FCB $86
	2104	+ FCC 'DMINU' ; 'DMINUS'
	2105	+ FCB $D3
	2106	+ FDB MINUS-8
	2107	+DMINUS FDB *+NATWID
	2108	+ LDD #0 ; #3~3
	2109	+ SUBD NATWID,U ; #2~7
	2110	+ STD NATWID,U ; #2~7
	2111	+ LDD #0 ; #3~3
	2112	+ SBCB 1,U ; #2~5
	2113	+ SBCA ,U ; #2~4
	2114	+ STD ,U ; #2~5
	2115	+ RTS ; #1~5 = #17~39
	2116	+* TFR S,X ; TSX :
	2117	+* COM 0,X
	2118	+* COM 1,X
	2119	+* COM 2,X
	2120	+* NEG 3,X
	2121	+* BNE DMINX
	2122	+* INC 2,X
	2123	+* BNE DMINX
	2124	+* INC 1,X
	2125	+* BNE DMINX
	2126	+* INC 0,X
	2127	+* DMINX JMP NEXT
	2128	+*
	2129	+* ######>> screen 30 <<
	2130	+* ======>> 37 <<
	2131	+* ( n1 n2 --- n1 n2 n1 )
	2132	+* Push a copy of the second word on stack.
	2133	+ FCB $84
	2134	+ FCC 'OVE' ; 'OVER'
	2135	+ FCB $D2
	2136	+ FDB DMINUS-9
	2137	+OVER FDB *+NATWID
	2138	+ LDD NATWID,U
	2139	+ PSHU D
	2140	+ RTS
	2141	+* TFR S,X ; TSX :
	2142	+* LDA 2,X
	2143	+* LDB 3,X
	2144	+* JMP PUSHBA
	2145	+*
	2146	+* ======>> 38 <<
	2147	+* ( n --- )
	2148	+* Discard the top word on stack.
	2149	+ FCB $84
	2150	+ FCC 'DRO' ; 'DROP'
	2151	+ FCB $D0
	2152	+ FDB OVER-7
	2153	+DROP FDB *+NATWID
	2154	+ LEAU NATWID,U
	2155	+ RTS
	2156	+* LEAS 1,S ;
	2157	+* LEAS 1,S ;
	2158	+* JMP NEXT
	2159	+*
	2160	+* ======>> 39 <<
	2161	+* ( n1 n2 --- n2 n1 )
	2162	+* Swap the top two words on stack.
	2163	+ FCB $84
	2164	+ FCC 'SWA' ; 'SWAP'
	2165	+ FCB $D0
	2166	+ FDB DROP-7
	2167	+SWAP FDB *+NATWID
	2168	+ PULU D,X
	2169	+ PSHU D
	2170	+ PSHU X
	2171	+ RTS
	2172	+* PULS A ;
	2173	+* PULS B ;
	2174	+* TFR S,X ; TSX :
	2175	+* LDX 0,X
	2176	+* LEAS 1,S ;
	2177	+* LEAS 1,S ;
	2178	+* PSHS B ;
	2179	+* PSHS A ;
	2180	+* STX N
	2181	+* LDX #N
	2182	+* JMP GETX
	2183	+*
	2184	+* ======>> 40 <<
	2185	+* ( n1 --- n1 n1 )
	2186	+* Push a copy of the top word on stack.
	2187	+ FCB $83
	2188	+ FCC 'DU' ; 'DUP'
	2189	+ FCB $D0
	2190	+ FDB SWAP-7
	2191	+DUP FDB *+NATWID
	2192	+ LDD ,U
	2193	+ PSHU D
	2194	+ RTS
	2195	+* PULS A ;
	2196	+* PULS B ;
	2197	+* PSHS B ;
	2198	+* PSHS A ;
	2199	+* JMP PUSHBA
	2200	+*
	2201	+* ######>> screen 31 <<
	2202	+* ======>> 41 <<
	2203	+* ( n adr --- )
	2204	+* Add the second word on stack to the word at the adr on top of stack.
	2205	+ FCB $82
	2206	+ FCC '+' ; '+!'
	2207	+ FCB $A1
	2208	+ FDB DUP-6
	2209	+PSTORE FDB *+NATWID
	2210	+ PULU X
	2211	+ LDD ,X
	2212	+ ADDD ,U++
	2213	+ STD ,X
	2214	+ RTS
	2215	+* TFR S,X ; TSX :
	2216	+* LDX 0,X
	2217	+* LEAS 1,S ;
	2218	+* LEAS 1,S ;
	2219	+* PULS A ; get stack data
	2220	+* PULS B ;
	2221	+* ADDB 1,X add & store low byte
	2222	+* STB 1,X
	2223	+* ADCA 0,X add & store hi byte
	2224	+* STA 0,X
	2225	+* JMP NEXT
	2226	+*
	2227	+* ======>> 42 <<
	2228	+* ( adr b --- )
	2229	+* Exclusive or byte at adr with low byte of top word.
	2230	+ FCB $86
	2231	+ FCC 'TOGGL' ; 'TOGGLE'
	2232	+ FCB $C5
	2233	+ FDB PSTORE-5
	2234	+TOGGLE FDB *+NATWID
	2235	+ PULU D,X
	2236	+ EORB ,X
	2237	+ STB ,X
	2238	+ RTS
	2239	+* Using the model code would be less likely to introduce bugs,
	2240	+* but that would sort-of defeat my purposes here.
	2241	+* Anyway, I can borrow from theoretically known good bif-6809 code
	2242	+* and it's fewer bytes and much faster code this way.
	2243	+* TOGGLE
	2244	+* FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
	2245	+* FDB SEMIS
	2246	+*
	2247	+* ######>> screen 32 <<
	2248	+* ======>> 43 <<
	2249	+* ( adr --- n )
	2250	+* Replace address on stack with the word at the address.
	2251	+ FCB $81 @
	2252	+ FCB $C0
	2253	+ FDB TOGGLE-9
	2254	+AT FDB *+NATWID
	2255	+ LDD [,U]
	2256	+ STD ,U
	2257	+ RTS
	2258	+* TFR S,X ; TSX :
	2259	+* LDX 0,X get address
	2260	+* LEAS 1,S ;
	2261	+* LEAS 1,S ;
	2262	+* JMP GETX
	2263	+*
	2264	+* ======>> 44 <<
	2265	+* ( adr --- b )
	2266	+* Replace address on top of stack with the byte at the address.
	2267	+* High byte of result is clear.
	2268	+ FCB $82
	2269	+ FCC 'C' ; 'C@'
	2270	+ FCB $C0
	2271	+ FDB AT-4
	2272	+CAT FDB *+NATWID
	2273	+ LDB [,U]
	2274	+ CLRA
	2275	+ STD ,U
	2276	+ RTS
	2277	+
	2278	+
	2279	+* TFR S,X ; TSX :
	2280	+* LDX 0,X
	2281	+* CLRA ;
	2282	+* LDB 0,X
	2283	+* LEAS 1,S ;
	2284	+* LEAS 1,S ;
	2285	+* JMP PUSHBA
	2286	+*
	2287	+* ======>> 45 <<
	2288	+* ( n adr --- )
	2289	+* Store second word on stack at address on top of stack.
	2290	+ FCB $81
	2291	+ FCB $A1
	2292	+ FDB CAT-5
	2293	+STORE FDB *+NATWID
	2294	+ LDD NATWID,U
	2295	+ STD [,U]
	2296	+ LEAU 2*NATWID,U
	2297	+ RTS
	2298	+* TFR S,X ; TSX :
	2299	+* LDX 0,X get address
	2300	+* LEAS 1,S ;
	2301	+* LEAS 1,S ;
	2302	+* JMP PULABX
	2303	+*
	2304	+* ======>> 46 <<
	2305	+* ( b adr --- )
	2306	+* Store low byte of second word on stack at address on top of stack.
	2307	+* High byte is ignored.
	2308	+ FCB $82
	2309	+ FCC 'C' ; 'C!'
	2310	+ FCB $A1
	2311	+ FDB STORE-4
	2312	+CSTORE FDB *+NATWID
	2313	+ LDB 3,U
	2314	+ STB [,U]
	2315	+ LEAU 2*NATWID,U
	2316	+ RTS
	2317	+* TFR S,X ; TSX :
	2318	+* LDX 0,X get address
	2319	+* LEAS 1,S ;
	2320	+* LEAS 1,S ;
	2321	+* LEAS 1,S ;
	2322	+* PULS B ;
	2323	+* STB 0,X
	2324	+* JMP NEXT
	2325	+ PAGE
	2326	+*
	2327	+* ######>> screen 33 <<
	2328	+* ======>> 47 <<
	2329	+* ( --- ) P
	2330	+* { : name sundry-activities ; } typical input
	2331	+* If executing (not compiling),
	2332	+* record the data stack mark in CSP,
	2333	+* Set the CONTEXT vocabulary to CURRENT,
	2334	+* CREATE a header,
	2335	+* set state to compile,
	2336	+* and compile the call to the trailing native CPU machine code DOCOL.
	2337	+*
	2338	+* This would not be hard to flatten to native code.
	2339	+* But that's not the purpose of a model.
	2340	+ FCB $C1 : immediate
	2341	+ FCB $BA
	2342	+ FDB CSTORE-5
	2343	+COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
	2344	+ FDB CREATE,RBRAK
	2345	+ FDB PSCODE
	2346	+
	2347	+* Here is the IP pusher for allowing
	2348	+* nested words in the virtual machine:
	2349	+* ( ;S is the equivalent un-nester )
	2350	+
	2351	+* ( *** oldIP )
	2352	+* Characteristic of a colon (:) definition.
	2353	+* Begins execution of a high-level definition,
	2354	+* i. e., nests the definition and begins processing icodes.
	2355	+* Mechanically, it pushes the IP (Y register)
	2356	+* and loads the Parameter Field Address of the definition which
	2357	+* called it into the IP.
	2358	+DOCOL LDD ,S ; Save the return address.
	2359	+ STY ,S ; Nest the old IP.
	2360	+ LEAY NATWID,X ; W still in X, bump to parameters, load as new IP.
	2361	+ TFR D,PC ; synthetic return to interpret.
	2362	+
	2363	+* DOCOL LDX RP make room in the stack
	2364	+* LEAX -1,X ;
	2365	+* LEAX -1,X ;
	2366	+* STX RP
	2367	+* LDA IP
	2368	+* LDB IP+1
	2369	+* STA 2,X Store address of the high level word
	2370	+* STB 3,X that we are starting to execute
	2371	+* LDX W Get first sub-word of that definition
	2372	+* JMP NEXT+2 and execute it
	2373	+*
	2374	+* ======>> 48 <<
	2375	+* ( --- ) P
	2376	+* { : name sundry-activities ; } typical input
	2377	+* ERROR check data stack against mark in CSP,
	2378	+* compile ;S,
	2379	+* unSMUDGE LATEST definition,
	2380	+* and set state to interpretation.
	2381	+ FCB $C1 ; imnediate code
	2382	+ FCB $BB
	2383	+ FDB COLON-4
	2384	+SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
	2385	+ FDB SEMIS
	2386	+*
	2387	+* ######>> screen 34 <<
	2388	+* ======>> 49 <<
	2389	+* ( n --- )
	2390	+* { value CONSTANT name } typical input
	2391	+* CREATE a header,
	2392	+* unSMUDGE it,
	2393	+* compile the constant value,
	2394	+* and compile the call to the trailing native CPU machine code DOCON.
	2395	+ FCB $88
	2396	+ FCC 'CONSTAN' ; 'CONSTANT'
	2397	+ FCB $D4
	2398	+ FDB SEMI-4
	2399	+CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
	2400	+* ( --- n )
	2401	+* Characteristic of a CONSTANT.
	2402	+* A CONSTANT simply loads its value from its parameter field
	2403	+* and pushes it on the stack.
	2404	+DOCON LDD NATWID,X ; Get the first natural width word of the parameter field.
	2405	+ PSHU D
	2406	+ RTS
	2407	+* DOCON LDX W
	2408	+* LDA 2,X
	2409	+* LDB 3,X A & B now contain the constant
	2410	+* JMP PUSHBA
	2411	+*
	2412	+* Not in model, needed for abstraction:
	2413	+* ( --- NATWID )
	2414	+* The byte width of objects on stack.
	2415	+ FCB $86
	2416	+ FCC 'NATWI' ; 'NATWID'
	2417	+ FCB $C4
	2418	+ FDB CON-11
	2419	+NATWC FDB DOCON
	2420	+NATWCV FDB NATWID
	2421	+*
	2422	+* Not in model, needed for abstraction:
	2423	+* Note that this is not defined as an INCREMENTER!
	2424	+* Coded to increment by the exact constant returned by NATWID
	2425	+* ( n --- n+NATWID )
	2426	+ FCB $84
	2427	+ FCC 'NAT' ; 'NAT+'
	2428	+ FCB $AB
	2429	+ FDB NATWC-9
	2430	+NATP FDB *+NATWID
	2431	+ LDD ,U
	2432	+ ADDD NATWCV,PCR ; Looking ahead, does not have to be PCRelative.
	2433	+ STD ,U
	2434	+ RTS
	2435	+* How this might have been done for 6800 model:
	2436	+* CLRA ; We know the natural width is less than 255, LOL.
	2437	+* LDAB NATWCV+1
	2438	+* TSX
	2439	+* ADDB 1,X
	2440	+* ADCA ,X
	2441	+* JMP STABX
	2442	+*
	2443	+* ======>> 50 <<
	2444	+* ( init --- )
	2445	+* { init VARIABLE name } typical input
	2446	+* Use CONSTANT to CREATE a header and compile the initial value, init,
	2447	+* then overwrite the characteristic to point to DOVAR.
	2448	+ FCB $88
	2449	+ FCC 'VARIABL' ; 'VARIABLE'
	2450	+ FCB $C5
	2451	+ FDB NATP-7
	2452	+VAR FDB DOCOL,CON,PSCODE
	2453	+* ( --- vadr )
	2454	+* Characteristic of a VARIABLE.
	2455	+* A VARIABLE pushes its PFA address on the stack.
	2456	+* The parameter field of a VARIABLE is the actual allocation of the variable,
	2457	+* so that pushing its address allows its contents to be @ed (fetched).
	2458	+* Ordinary arrays and strings that do not subscript themselves
	2459	+* may be allocated by defining a variable
	2460	+* and immediately ALLOTting the remaining needed space.
	2461	+* VARIABLES are global to all users,
	2462	+* and thus should be hidden in resource monitors, but aren't.
	2463	+DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters.
	2464	+ PSHU X
	2465	+ RTS
	2466	+* DOVAR LDA W
	2467	+* LDB W+1
	2468	+* ADDB #2
	2469	+* ADCA #0 A,B now contain the address of the variable
	2470	+* JMP PUSHBA
	2471	+*
	2472	+* ======>> 51 <<
	2473	+* ( ub --- )
	2474	+* { uboffset USER name } typical input
	2475	+* CREATE a header and compile the unsigned byte offset in the per-USER table,
	2476	+* then overwrite the header with a call to DOUSER.
	2477	+* The USER is entirely responsible for maintaining allocation!
	2478	+ FCB $84
	2479	+ FCC 'USE' ; 'USER'
	2480	+ FCB $D2
	2481	+ FDB VAR-11
	2482	+USER FDB DOCOL,CON,PSCODE
	2483	+* ( --- vadr )
	2484	+* Characteristic of a per-USER variable.
	2485	+* USER variables are similiar to VARIABLEs,
	2486	+* but are allocated (by hand!) in the per-user table.
	2487	+* A USER variable's parameter field contains its offset in the per-user table.
	2488	+DOUSER TFR DP,A ; Make a pointer to the direct page.
	2489	+ CLRB
	2490	+* See Alternative -- alternatives start from this point.
	2491	+ ADDD NATWID,X ; Add it to the offset to the per-user variable.
	2492	+ PSHU D
	2493	+ TFR D,X ; Cache the pointer in X for the caller.
	2494	+ RTS
	2495	+* Hey, the per-user table could actually be larger than 256 bytes!
	2496	+* But we knew that. It's just not as esthetic to calculate it this way.
	2497	+* Alternative A:
	2498	+* LDX NATWID,X ; Keep the offset
	2499	+* EXG D,X ; Prepare for EA
	2500	+* LEAX D,X
	2501	+* PSHU X
	2502	+* RTS
	2503	+* Alternative B:
	2504	+* PSHS Y ; Get Y free for calculations.
	2505	+* TFR D,Y ; Y points to the UP base
	2506	+* LDD NATWID,X ; Get the offset
	2507	+* LEAX D,Y ; Leave the pointer cached in X.
	2508	+* PSHU X
	2509	+* PULS Y,PC
	2510	+*
	2511	+* From the 6800 model:
	2512	+* DOUSER LDX W get offset into user's table
	2513	+* LDA 2,X
	2514	+* LDB 3,X
	2515	+* ADDB UP+1 add to users base address
	2516	+* ADCA UP
	2517	+* JMP PUSHBA push address of user's variable
	2518	+*
	2519	+* ######>> screen 35 <<
	2520	+* ======>> 52 <<
	2521	+* ( --- 0 )
	2522	+ FCB $81
	2523	+ FCB $B0 0
	2524	+ FDB USER-7
	2525	+ZERO FDB DOCON
	2526	+ FDB 0000
	2527	+*
	2528	+* ======>> 53 <<
	2529	+* ( --- 1 )
	2530	+ FCB $81
	2531	+ FCB $B1 1
	2532	+ FDB ZERO-4
	2533	+ONE FDB DOCON
	2534	+ONEV FDB 1
	2535	+*
	2536	+* ======>> 54 <<
	2537	+* ( --- 2 )
	2538	+ FCB $81
	2539	+ FCB $B2 2
	2540	+ FDB ONE-4
	2541	+TWO FDB DOCON
	2542	+TWOV FDB 2
	2543	+*
	2544	+* ======>> 55 <<
	2545	+* ( --- 3 )
	2546	+ FCB $81
	2547	+ FCB $B3 3
	2548	+ FDB TWO-4
	2549	+THREE FDB DOCON
	2550	+ FDB 3
	2551	+*
	2552	+* ======>> 56 <<
	2553	+* ( --- SP )
	2554	+* ASCII SPACE character
	2555	+ FCB $82
	2556	+ FCC 'B' ; 'BL'
	2557	+ FCB $CC
	2558	+ FDB THREE-4
	2559	+BL FDB DOCON ascii blank
	2560	+ FDB $20
	2561	+*
	2562	+* ======>> 57 <<
	2563	+* This really shouldn't be a CONSTANT.
	2564	+* ( --- adr )
	2565	+* The base of the disk buffer space.
	2566	+ FCB $85
	2567	+ FCC 'FIRS' ; 'FIRST'
	2568	+ FCB $D4
	2569	+ FDB BL-5
	2570	+FIRST FDB DOCON
	2571	+ FDB BUFBAS
	2572	+* FDB MEMEND-528 (132 * NBLK)
	2573	+*
	2574	+* ======>> 58 <<
	2575	+* This really shouldn't be a CONSTANT.
	2576	+* ( --- adr )
	2577	+* The limit of the disk buffer space.
	2578	+ FCB $85
	2579	+ FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
	2580	+ FCB $D4
	2581	+ FDB FIRST-8
	2582	+LIMIT FDB DOCON
	2583	+ FDB BUFBAS+BUFSZ
	2584	+* In 6800 model, was
	2585	+* FDB MEMEND
	2586	+*
	2587	+* ======>> 59 <<
	2588	+* ( --- sectorsize )
	2589	+* The size, in bytes, of a buffer control region.
	2590	+ FCB $85
	2591	+ FCC 'B/CT' ; 'B/CTL' : (bytes/control region)
	2592	+ FCB $CC
	2593	+ FDB LIMIT-8
	2594	+BCTL FDB DOCON
	2595	+ FDB SECTRL
	2596	+*
	2597	+* ( --- sectorsize )
	2598	+* The size, in bytes, of a buffer.
	2599	+ FCB $85
	2600	+ FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
	2601	+ FCB $C6
	2602	+ FDB BCTL-8
	2603	+BBUF FDB DOCON
	2604	+ FDB SECTSZ
	2605	+* Hardcoded in 6800 model:
	2606	+* FDB 128
	2607	+*
	2608	+* ======>> 60 <<
	2609	+* ( --- blocksperscreen )
	2610	+* The size, in blocks, of a screen.
	2611	+* Should this be the same as NBLK, the number of block buffers maintained?
	2612	+ FCB $85
	2613	+ FCC 'B/SC' ; 'B/SCR' : (blocks/screen)
	2614	+ FCB $D2
	2615	+ FDB BBUF-8
	2616	+BSCR FDB DOCON
	2617	+ FDB SCRSZ/SECTSZ
	2618	+* Hardcoded in 6800 model as:
	2619	+* FDB 8
	2620	+* blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
	2621	+*
	2622	+* ======>> 61 <<
	2623	+* ( n --- adr )
	2624	+* Calculate the address of entry (#n/2) in the boot-up parameter table.
	2625	+* (Adds the base of the boot-up table to n.)
	2626	+ FCB $87
	2627	+ FCC '+ORIGI' ; '+ORIGIN'
	2628	+ FCB $CE
	2629	+ FDB BSCR-8
	2630	+PORIG FDB DOCOL,LIT,ORIG,PLUS
	2631	+ FDB SEMIS
	2632	+*
	2633	+* ######>> screen 36 <<
	2634	+* ======>> 62 <<
	2635	+* ( n --- adr )
	2636	+* This is the per-task variable recording the initial parameter stack pointer.
	2637	+ FCB $82
	2638	+ FCC 'S' ; 'S0'
	2639	+ FCB $B0
	2640	+ FDB PORIG-10
	2641	+SZERO FDB DOUSER
	2642	+ FDB XSPZER-UORIG
	2643	+*
	2644	+* ======>> 63 <<
	2645	+* ( n --- adr )
	2646	+* This is the per-task variable recording the initial return stack pointer.
	2647	+ FCB $82
	2648	+ FCC 'R' ; 'R0'
	2649	+ FCB $B0
	2650	+ FDB SZERO-5
	2651	+RZERO FDB DOUSER
	2652	+ FDB XRZERO-UORIG
	2653	+*
	2654	+* ======>> 64 <<
	2655	+* ( --- vadr )
	2656	+* Terminal Input Buffer address.
	2657	+* Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
	2658	+ FCB $83
	2659	+ FCC 'TI' ; 'TIB'
	2660	+ FCB $C2
	2661	+ FDB RZERO-5
	2662	+TIB FDB DOUSER
	2663	+ FDB XTIB-UORIG
	2664	+*
	2665	+* ======>> 65 <<
	2666	+* ( --- maxnamewidth )
	2667	+* This is the maximum width to which symbol names will be recorded.
	2668	+ FCB $85
	2669	+ FCC 'WIDT' ; 'WIDTH'
	2670	+ FCB $C8
	2671	+ FDB TIB-6
	2672	+WIDTH FDB DOUSER
	2673	+ FDB XWIDTH-UORIG
	2674	+*
	2675	+* ======>> 66 <<
	2676	+* ( --- vadr )
	2677	+* Availability of error messages on disk.
	2678	+* Contains 1 if messages available,
	2679	+* 0 if not,
	2680	+* -1 if a disk error has occurred.
	2681	+ FCB $87
	2682	+ FCC 'WARNIN' ; 'WARNING'
	2683	+ FCB $C7
	2684	+ FDB WIDTH-8
	2685	+WARN FDB DOUSER
	2686	+ FDB XWARN-UORIG
	2687	+*
	2688	+* ======>> 67 <<
	2689	+* ( --- vadr )
	2690	+* Boundary for FORGET.
	2691	+ FCB $85
	2692	+ FCC 'FENC' ; 'FENCE'
	2693	+ FCB $C5
	2694	+ FDB WARN-10
	2695	+FENCE FDB DOUSER
	2696	+ FDB XFENCE-UORIG
	2697	+*
	2698	+* ======>> 68 <<
	2699	+* ( --- vadr )
	2700	+* Dictionary pointer, fetched by HERE.
	2701	+ FCB $82
	2702	+ FCC 'D' ; 'DP' : points to first free byte at end of dictionary
	2703	+ FCB $D0
	2704	+ FDB FENCE-8
	2705	+DICTPT FDB DOUSER
	2706	+ FDB XDICTP-UORIG
	2707	+*
	2708	+* ======>> 68.5 <<
	2709	+* ( --- vadr ) ******* Need to check what this is!
	2710	+* Used in maintaining vocabularies.
	2711	+* I think it points to the "parent" vocabulary, but I'm not sure.
	2712	+* Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
	2713	+ FCB $88
	2714	+ FCC 'VOC-LIN' ; 'VOC-LINK'
	2715	+ FCB $CB
	2716	+ FDB DICTPT-5
	2717	+VOCLIN FDB DOUSER
	2718	+ FDB XVOCL-UORIG
	2719	+*
	2720	+* ======>> 69 <<
	2721	+* ( --- vadr )
	2722	+* Disk block being interpreted.
	2723	+* Zero refers to terminal.
	2724	+* ****** Should be made a 32 bit user variable! ******
	2725	+* But the base system needs to have full 32 bit support, div and mul, etc.
	2726	+* before we can do that.
	2727	+ FCB $83
	2728	+ FCC 'BL' ; 'BLK'
	2729	+ FCB $CB
	2730	+ FDB VOCLIN-11
	2731	+BLK FDB DOUSER
	2732	+ FDB XBLK-UORIG
	2733	+*
	2734	+* ======>> 70 <<
	2735	+* ( --- vadr )
	2736	+* Input buffer offset/cursor.
	2737	+ FCB $82
	2738	+ FCC 'I' ; 'IN' : scan pointer for input line buffer
	2739	+ FCB $CE
	2740	+ FDB BLK-6
	2741	+IN FDB DOUSER
	2742	+ FDB XIN-UORIG
	2743	+*
	2744	+* ======>> 71 <<
	2745	+* ( --- vadr )
	2746	+* Output buffer offset/cursor.
	2747	+ FCB $83
	2748	+ FCC 'OU' ; 'OUT'
	2749	+ FCB $D4
	2750	+ FDB IN-5
	2751	+OUT FDB DOUSER
	2752	+ FDB XOUT-UORIG
	2753	+*
	2754	+* ======>> 72 <<
	2755	+* ( --- vadr )
	2756	+* Screen currently being edited, once we have an editor running.
	2757	+ FCB $83
	2758	+ FCC 'SC' ; 'SCR'
	2759	+ FCB $D2
	2760	+ FDB OUT-6
	2761	+SCR FDB DOUSER
	2762	+ FDB XSCR-UORIG
	2763	+* ######>> screen 37 <<
	2764	+*
	2765	+* ======>> 73 <<
	2766	+* ( --- vadr )
	2767	+* Sector offset for LOADing screens,
	2768	+* set by DRIVE to make a new drive the default.
	2769	+* This should also be 32 bit or bigger.
	2770	+ FCB $86
	2771	+ FCC 'OFFSE' ; 'OFFSET'
	2772	+ FCB $D4
	2773	+ FDB SCR-6
	2774	+OFSET FDB DOUSER
	2775	+ FDB XOFSET-UORIG
	2776	+*
	2777	+* ======>> 74 <<
	2778	+* ( --- vadr )
	2779	+* Current context of interpretation (vocabulary root).
	2780	+ FCB $87
	2781	+ FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
	2782	+ FCB $D4
	2783	+ FDB OFSET-9
	2784	+CONTXT FDB DOUSER
	2785	+ FDB XCONT-UORIG
	2786	+*
	2787	+* ======>> 75 <<
	2788	+* ( --- vadr )
	2789	+* Current context of definition (vocabulary root).
	2790	+ FCB $87
	2791	+ FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
	2792	+ FCB $D4
	2793	+ FDB CONTXT-10
	2794	+CURENT FDB DOUSER
	2795	+ FDB XCURR-UORIG
	2796	+*
	2797	+* ======>> 76 <<
	2798	+* ( --- vadr )
	2799	+* Compiler/interpreter state.
	2800	+ FCB $85
	2801	+ FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
	2802	+ FCB $C5
	2803	+ FDB CURENT-10
	2804	+STATE FDB DOUSER
	2805	+ FDB XSTATE-UORIG
	2806	+*
	2807	+* ======>> 77 <<
	2808	+* ( --- vadr )
	2809	+* Numeric conversion base.
	2810	+ FCB $84
	2811	+ FCC 'BAS' ; 'BASE' : number base for all input & output
	2812	+ FCB $C5
	2813	+ FDB STATE-8
	2814	+BASE FDB DOUSER
	2815	+ FDB XBASE-UORIG
	2816	+*
	2817	+* ======>> 78 <<
	2818	+* ( --- vadr )
	2819	+* Decimal point location for output.
	2820	+ FCB $83
	2821	+ FCC 'DP' ; 'DPL'
	2822	+ FCB $CC
	2823	+ FDB BASE-7
	2824	+DPL FDB DOUSER
	2825	+ FDB XDPL-UORIG
	2826	+*
	2827	+* ======>> 79 <<
	2828	+* ( --- vadr )
	2829	+* Field width for I/O formatting.
	2830	+ FCB $83
	2831	+ FCC 'FL' ; 'FLD'
	2832	+ FCB $C4
	2833	+ FDB DPL-6
	2834	+FLD FDB DOUSER
	2835	+ FDB XFLD-UORIG
	2836	+*
	2837	+* ======>> 80 <<
	2838	+* ( --- vadr )
	2839	+* Compiler stack mark for stack check.
	2840	+ FCB $83
	2841	+ FCC 'CS' ; 'CSP'
	2842	+ FCB $D0
	2843	+ FDB FLD-6
	2844	+CSP FDB DOUSER
	2845	+ FDB XCSP-UORIG
	2846	+*
	2847	+* ======>> 81 <<
	2848	+* ( --- vadr )
	2849	+* Editing cursor location.
	2850	+ FCB $82
	2851	+ FCC 'R' ; 'R#'
	2852	+ FCB $A3
	2853	+ FDB CSP-6
	2854	+RNUM FDB DOUSER
	2855	+ FDB XRNUM-UORIG
	2856	+*
	2857	+* ======>> 82 <<
	2858	+* ( --- vadr )
	2859	+* Pointer to last HELD character in PAD.
	2860	+ FCB $83
	2861	+ FCC 'HL' ; 'HLD'
	2862	+ FCB $C4
	2863	+ FDB RNUM-5
	2864	+HLD FDB DOCON
	2865	+ FDB XHLD
	2866	+*
	2867	+* ======>> 82.5 <<== SPECIAL
	2868	+* ( --- vadr )
	2869	+* Line width of active terminal.
	2870	+ FCB $87
	2871	+ FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
	2872	+ FCB $D3
	2873	+ FDB HLD-6
	2874	+COLUMS FDB DOUSER
	2875	+ FDB XCOLUM-UORIG
	2876	+*
	2877	+* ######>> screen 38 <<
	2878	+**
	2879	+** An INCREMENTER probably should not be defined without a defined CONSTANT?
	2880	+**
	2881	+** Make an INCREMENTER compiling word (not in model):
	2882	+** ( n --- )
	2883	+** { n INCREMENTER name } typical input
	2884	+** CREATE a header and compile the increment constant,
	2885	+** then overwrite the header with a call to DOINC.
	2886	+* FCB $8B
	2887	+* FCC 'INCREMENTE' ; 'INCREMENTER'
	2888	+* FCB $D2
	2889	+* FDB COLUMS-10
	2890	+* INCR FDB DOCOL,CON,PSCODE
	2891	+** ( n --- ninc )
	2892	+** Characteristic of an INCREMENTER.
	2893	+** This is too naive:
	2894	+* DOINC LDD ,U
	2895	+* ADDD NATWID,X ; Add the increment.
	2896	+* STD ,U
	2897	+* RTS
	2898	+* Compiling word should check that it is compiling a CONSTANT.
	2899	+*
	2900	+* ======>> 83 <<
	2901	+* ( n --- n+1 )
	2902	+ FCB $82
	2903	+ FCC '1' ; '1+'
	2904	+ FCB $AB
	2905	+ FDB COLUMS-10
	2906	+* Using the model keeps things semantically connected for other processors:
	2907	+ONEP FDB DOCOL,ONE,PLUS
	2908	+ FDB SEMIS
	2909	+** Greedy alternative:
	2910	+* ONEP FDB *+NATWID
	2911	+* LDD ,U
	2912	+* ADDD ONEV,PCR
	2913	+* STD ,U
	2914	+* RTS
	2915	+* Naive alternative:
	2916	+* ONEP FDB DOINC
	2917	+* FDB 1
	2918	+* Naive alternative:
	2919	+* ONEP FDB *+NATWID
	2920	+* LDD ,U
	2921	+* ADDD #1 ; It's hard to imagine 1+ being other than 1.
	2922	+* STD ,U
	2923	+* RTS
	2924	+*
	2925	+* ======>> 84 <<
	2926	+* ( n --- n+2 )
	2927	+ FCB $82
	2928	+ FCC '2' ; '2+'
	2929	+ FCB $AB
	2930	+ FDB ONEP-5
	2931	+* Using the model keeps things semantically connected for other processors:
	2932	+TWOP FDB DOCOL,TWO,PLUS
	2933	+ FDB SEMIS
	2934	+** Greedy alternative:
	2935	+* TWOP FDB *+NATWID
	2936	+* LDD ,U
	2937	+* ADDD TWOV,PCR ; See NAT+ (NATP)
	2938	+* STD ,U
	2939	+* RTS
	2940	+* Naive alternative:
	2941	+* TWOP FDB DOINC
	2942	+* FDB 2
	2943	+* Naive alternative:
	2944	+* TWOP FDB *+NATWID
	2945	+* LDD ,U
	2946	+* ADDD #2 ; See NAT+ (NATP)
	2947	+* STD ,U
	2948	+* RTS
	2949	+*
	2950	+* ======>> 85 <<
	2951	+* ( --- adr )
	2952	+* Get the DICTPT allocation, like a USER constant.
	2953	+* Should check the stack and heap for collision.
	2954	+ FCB $84
	2955	+ FCC 'HER' ; 'HERE'
	2956	+ FCB $C5
	2957	+ FDB TWOP-5
	2958	+HERE FDB DOCOL,DICTPT,AT
	2959	+ FDB SEMIS
	2960	+*
	2961	+* ======>> 86 <<
	2962	+* ( n --- )
	2963	+* Increase/decrease heap (add n to DP),
	2964	+* Should ERROR check stack/heap.
	2965	+ FCB $85
	2966	+ FCC 'ALLO' ; 'ALLOT'
	2967	+ FCB $D4
	2968	+ FDB HERE-7
	2969	+ALLOT FDB DOCOL,DICTPT,PSTORE
	2970	+ FDB SEMIS
	2971	+*
	2972	+* ======>> 87 <<
	2973	+* ( n --- )
	2974	+* Store word n at DP++,
	2975	+* Should ERROR check stack/heap.
	2976	+ FCB $81 ; , (COMMA)
	2977	+ FCB $AC
	2978	+ FDB ALLOT-8
	2979	+COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT
	2980	+ FDB SEMIS
	2981	+* COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
	2982	+* FDB SEMIS
	2983	+*
	2984	+* ======>> 88 <<
	2985	+* ( b --- )
	2986	+* Store byte b at DP+,
	2987	+* Should ERROR check stack/heap.
	2988	+ FCB $82
	2989	+ FCC 'C' ; 'C,'
	2990	+ FCB $AC
	2991	+ FDB COMMA-4
	2992	+CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
	2993	+ FDB SEMIS
	2994	+*
	2995	+* ======>> 89 <<
	2996	+* ( n1 n2 --- n1-n2 )
	2997	+* Subtract top two words.
	2998	+ FCB $81 ; -
	2999	+ FCB $AD
	3000	+ FDB CCOMM-5
	3001	+SUB FDB *+NATWID
	3002	+ LDD NATWID,U ; #2~6
	3003	+ SUBD ,U++ ; #2~9
	3004	+ STD ,U ; #2~5
	3005	+ RTS ; #1~5 = #7~25
	3006	+* SUB FDB DOCOL,MINUS,PLUS
	3007	+* FDB SEMIS ; Costs 6 bytes and lots of cycles.
	3008	+*
	3009	+* ======>> 90 <<
	3010	+* ( n1 n2 --- n1==n2 )
	3011	+* Return flag true if n1 and n2 are equal, otherwise false.
	3012	+ FCB $81 =
	3013	+ FCB $BD
	3014	+ FDB SUB-4
	3015	+EQUAL FDB DOCOL,SUB,ZEQU
	3016	+ FDB SEMIS
	3017	+*
	3018	+* ======>> 91 <<
	3019	+* ( n1 n2 --- n1<n2 )
	3020	+* Return flag true if n1 is less than n2, otherwise false.
	3021	+ FCB $81 <
	3022	+ FCB $BC
	3023	+ FDB EQUAL-4
	3024	+LESS FDB *+NATWID
	3025	+ LDD NATWID,U
	3026	+ SUBD ,U++
	3027	+ BGE FALSE
	3028	+TRUE LDD #1
	3029	+ STD ,U
	3030	+ RTS
	3031	+FALSE LDD #0
	3032	+ STD ,U
	3033	+ RTS
	3034	+* PULS A ;
	3035	+* PULS B ;
	3036	+* TFR S,X ; TSX :
	3037	+* CMPA 0,X
	3038	+* LEAS 1,S ;
	3039	+* BGT LESST
	3040	+* BNE LESSF
	3041	+* CMPB 1,X ; Why not sub, sbc, bge?
	3042	+* BHI LESST
	3043	+* LESSF CLRB ;
	3044	+* BRA LESSX
	3045	+* LESST LDB #1
	3046	+* LESSX CLRA ;
	3047	+* LEAS 1,S ;
	3048	+* JMP PUSHBA
	3049	+*
	3050	+* ======>> 92 <<
	3051	+* ( n1 n2 --- n1>n2 )
	3052	+* Return flag true if n1 is greater than n2, false otherwise.
	3053	+ FCB $81 >
	3054	+ FCB $BE
	3055	+ FDB LESS-4
	3056	+GREAT FDB DOCOL,SWAP,LESS
	3057	+ FDB SEMIS
	3058	+*
	3059	+* ======>> 93 <<
	3060	+* ( n1 n2 n3 --- n2 n3 n1 )
	3061	+* Rotate the top three words on stack,
	3062	+* bringing the third word to the top.
	3063	+ FCB $83
	3064	+ FCC 'RO' ; 'ROT'
	3065	+ FCB $D4
	3066	+ FDB GREAT-4
	3067	+ROT FDB *+NATWID
	3068	+ PSHS Y
	3069	+ PULU D,X,Y
	3070	+ PSHU D,X
	3071	+ PSHU Y
	3072	+ PULS Y,PC
	3073	+* ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
	3074	+* FDB SEMIS
	3075	+*
	3076	+* ======>> 94 <<
	3077	+* ( --- )
	3078	+* EMIT a SPACE.
	3079	+ FCB $85
	3080	+ FCC 'SPAC' ; 'SPACE'
	3081	+ FCB $C5
	3082	+ FDB ROT-6
	3083	+SPACE FDB DOCOL,BL,EMIT
	3084	+ FDB SEMIS
	3085	+*
	3086	+* ======>> 95 <<
	3087	+* ( n0 n1 --- min(n0,n1) )
	3088	+* Leave the minimum of the top two integers.
	3089	+* Being too greedy here, but, whatever.
	3090	+ FCB $83
	3091	+ FCC 'MI' ; 'MIN'
	3092	+ FCB $CE
	3093	+ FDB SPACE-8
	3094	+MIN FDB *+NATWID
	3095	+ PULU D
	3096	+ CMPD ,U
	3097	+ BLE MINX
	3098	+ STD ,U
	3099	+MINX RTS
	3100	+* MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
	3101	+* FDB MIN2-*-NATWID
	3102	+* FDB SWAP
	3103	+* MIN2 FDB DROP
	3104	+* FDB SEMIS
	3105	+*
	3106	+* ======>> 96 <<
	3107	+* ( n0 n1 --- max(n0,n1) )
	3108	+* Leave the maximum of the top two integers.
	3109	+* Really should leave this as in the model.
	3110	+ FCB $83
	3111	+ FCC 'MA' ; 'MAX'
	3112	+ FCB $D8
	3113	+ FDB MIN-6
	3114	+MAX FDB *+NATWID
	3115	+ PULU D
	3116	+ CMPD ,U
	3117	+ BLE MAXX
	3118	+ STD ,U
	3119	+MAXX RTS
	3120	+* MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
	3121	+* FDB MAX2-*-NATWID
	3122	+* FDB SWAP
	3123	+* MAX2 FDB DROP
	3124	+* FDB SEMIS
	3125	+*
	3126	+* ======>> 97 <<
	3127	+* ( 0 --- 0 )
	3128	+* ( n --- n n )
	3129	+* DUP if non-zero.
	3130	+ FCB $84
	3131	+ FCC '-DU' ; '-DUP'
	3132	+ FCB $D0
	3133	+ FDB MAX-6
	3134	+DDUP FDB *+NATWID
	3135	+ LDD ,U
	3136	+ BEQ DDUPX
	3137	+ PSHU D
	3138	+DDUPX RTS
	3139	+* DDUP FDB DOCOL,DUP,ZBRAN
	3140	+* FDB DDUP2-*-NATWID
	3141	+* FDB DUP
	3142	+* DDUP2 FDB SEMIS
	3143	+*
	3144	+* ######>> screen 39 <<
	3145	+* ======>> 98.1 <<
	3146	+* Supplemental:
	3147	+* ( n<0 --- -1 )
	3148	+* ( n>=~ --- 1 )
	3149	+* Change top integer to its sign.
	3150	+ FCB $86
	3151	+ FCC 'SIGNU' ; 'SIGNUM'
	3152	+ FCB $CD
	3153	+ FDB DDUP-7
	3154	+SIGNUM FDB *+NATWID
	3155	+SIGNUE LDB #1
	3156	+ LDA ,U
	3157	+ BPL SIGNUP
	3158	+ NEGB
	3159	+SIGNUP SEX ; Couldn't they have called SignEXtend EXT instead?
	3160	+ STD ,U ; Am I too much of a prude?
	3161	+ RTS
	3162	+* 6800 model version should be something like this:
	3163	+* LDB #1
	3164	+* CLRA
	3165	+* TSX
	3166	+* TST ,X
	3167	+* BPL SIGNUP
	3168	+* NEGB
	3169	+* COMA
	3170	+* SIGNUP JMP STABX
	3171	+*
	3172	+* ======>> 98 <<
	3173	+* ( adr1 direction --- adr2 )
	3174	+* TRAVERSE the symbol name.
	3175	+* If direction is 1, find the end.
	3176	+* If direction is -1, find the beginning.
	3177	+ FCB $88
	3178	+ FCC 'TRAVERS' ; 'TRAVERSE'
	3179	+ FCB $C5
	3180	+ FDB SIGNUM-9
	3181	+TRAV FDB *+NATWID
	3182	+ BSR SIGNUE ; Convert negative to -, zero or positive to 1.
	3183	+ LDD ,U++ ; Still in D, but we have to pop it anyway.
	3184	+ LDX ,U ; If D is 1 or -1, so is B.
	3185	+ LDA #$7F
	3186	+TRAVLP LEAX B,X ; Don't look at the one we start at.
	3187	+ CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL.
	3188	+ BCC TRAVLP
	3189	+TRAVDN STX ,U
	3190	+ RTS
	3191	+* Doing this in 6809 just because it can be done may be getting too greedy.
	3192	+* TRAV FDB DOCOL,SWAP
	3193	+* TRAV2 FDB OVER,PLUS,LIT8
	3194	+* FCB $7F
	3195	+* FDB OVER,CAT,LESS,ZBRAN
	3196	+* FDB TRAV2-*-NATWID
	3197	+* FDB SWAP,DROP
	3198	+* FDB SEMIS
	3199	+*
	3200	+* ======>> 99 <<
	3201	+* ( --- symptr )
	3202	+* Fetch CURRENT as a per-USER constant.
	3203	+ FCB $86
	3204	+ FCC 'LATES' ; 'LATEST'
	3205	+ FCB $D4
	3206	+ FDB TRAV-11
	3207	+LATEST FDB DOCOL,CURENT,AT,AT
	3208	+ FDB SEMIS
	3209	+* LATEST FDB *+NATWID
	3210	+* Getting too greedy:
	3211	+* Version 1:
	3212	+* TFR DP,A
	3213	+* CLRB
	3214	+* TFR D,X
	3215	+* LDD CURENT+NATWID,PCR
	3216	+* LDX [D,X]
	3217	+* PSHU X ; Leave the address in X.
	3218	+* RTS
	3219	+* Version 2:
	3220	+* LEAX CURENT,PCR
	3221	+* JSR [,X]
	3222	+* PULU X
	3223	+* LDX [,X]
	3224	+* PSHU X
	3225	+* RTS
	3226	+* Too greedy, too many smantic holes to fall through.
	3227	+* If the address at the CFA is made relative,
	3228	+* this is part of the code that would be affected
	3229	+* if it is in native CPU code.
	3230	+*
	3231	+* ======>> 100 <<
	3232	+* Wanted to do these as INCREMENTERs,
	3233	+* but I need to stick with the model as much as possible,
	3234	+* (mostly, LOL) adding code only to make the model more clear.
	3235	+* ( pfa --- lfa )
	3236	+* Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
	3237	+ FCB $83
	3238	+ FCC 'LF' ; 'LFA'
	3239	+ FCB $C1
	3240	+ FDB LATEST-9
	3241	+LFA FDB DOCOL,LIT8
	3242	+* FCB 4
	3243	+ FCB 2*NATWID
	3244	+ FDB SUB
	3245	+ FDB SEMIS
	3246	+*
	3247	+* ======>> 101 <<
	3248	+* ( pfa --- cfa )
	3249	+* Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
	3250	+ FCB $83
	3251	+ FCC 'CF' ; 'CFA'
	3252	+ FCB $C1
	3253	+ FDB LFA-6
	3254	+* CFA FDB DOCOL,TWO,SUB
	3255	+CFA FDB DOCOL,NATWC,SUB
	3256	+ FDB SEMIS
	3257	+*
	3258	+* ======>> 102 <<
	3259	+* ( pfa --- nfa )
	3260	+* Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
	3261	+ FCB $83
	3262	+ FCC 'NF' ; 'NFA'
	3263	+ FCB $C1
	3264	+ FDB CFA-6
	3265	+NFA FDB DOCOL,LIT8
	3266	+* FCB 5
	3267	+ FCB NATWID*2+1
	3268	+ FDB SUB,ONE,MINUS,TRAV
	3269	+ FDB SEMIS
	3270	+*
	3271	+* ======>> 103 <<
	3272	+* ( nfa --- pfa )
	3273	+* Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
	3274	+ FCB $83
	3275	+ FCC 'PF' ; 'PFA'
	3276	+ FCB $C1
	3277	+ FDB NFA-6
	3278	+PFA FDB DOCOL,ONE,TRAV,LIT8
	3279	+* FCB 5
	3280	+ FCB NATWID*2+1
	3281	+ FDB PLUS
	3282	+ FDB SEMIS
	3283	+*
	3284	+* ######>> screen 40 <<
	3285	+* ======>> 104 <<
	3286	+* ( --- )
	3287	+* Save the parameter stack pointer in CSP for compiler checks.
	3288	+ FCB $84
	3289	+ FCC '!CS' ; '!CSP'
	3290	+ FCB $D0
	3291	+ FDB PFA-6
	3292	+SCSP FDB DOCOL,SPAT,CSP,STORE
	3293	+ FDB SEMIS
	3294	+*
	3295	+* ======>> 105 <<
	3296	+* ( 0 n --- ) ( *** )
	3297	+* ( true n --- IN BLK ) ( anything *** nothing )
	3298	+* If flag is false, do nothing.
	3299	+* If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
	3300	+* Leaves cursor position (IN)
	3301	+* and currently loading block number (BLK) on stack, for analysis.
	3302	+*
	3303	+* This one is too important to be high-level Forth codes.
	3304	+* When we have an error, we want to disturb as little as possible.
	3305	+* But fixing that cascades through ERROR and MESSAGE
	3306	+* into the disk block system.
	3307	+* And we aren't ready for that yet.
	3308	+ FCB $86
	3309	+ FCC '?ERRO' ; '?ERROR'
	3310	+ FCB $D2
	3311	+ FDB SCSP-7
	3312	+* QERR FDB *+NATWID
	3313	+* LDD NATWID,U
	3314	+* BNE QERROR
	3315	+* LEAU 2*NATWID,U
	3316	+* RTS
	3317	+** this doesn't work anyway: QERROR LBR ERROR
	3318	+QERR FDB DOCOL,SWAP,ZBRAN
	3319	+ FDB QERR2-*-NATWID
	3320	+ FDB ERROR,BRAN
	3321	+ FDB QERR3-*-NATWID
	3322	+QERR2 FDB DROP
	3323	+QERR3 FDB SEMIS
	3324	+*
	3325	+* ======>> 106 <<
	3326	+* STATE is compiling:
	3327	+* ( --- ) ( *** )
	3328	+* STATE is compiling:
	3329	+* ( --- IN BLK ) ( anything *** nothing )
	3330	+* ERROR if not compiling.
	3331	+ FCB $85
	3332	+ FCC '?COM' ; '?COMP'
	3333	+ FCB $D0
	3334	+ FDB QERR-9
	3335	+QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8
	3336	+ FCB $11
	3337	+ FDB QERR
	3338	+ FDB SEMIS
	3339	+*
	3340	+* ======>> 107 <<
	3341	+* STATE is executing:
	3342	+* ( --- ) ( *** )
	3343	+* STATE is executing:
	3344	+* ( --- IN BLK ) ( anything *** nothing )
	3345	+* ERROR if not executing.
	3346	+ FCB $85
	3347	+ FCC '?EXE' ; '?EXEC'
	3348	+ FCB $C3
	3349	+ FDB QCOMP-8
	3350	+QEXEC FDB DOCOL,STATE,AT,LIT8
	3351	+ FCB $12
	3352	+ FDB QERR
	3353	+ FDB SEMIS
	3354	+*
	3355	+* ======>> 108 <<
	3356	+* ( n1 n1 --- ) ( *** )
	3357	+* ( n1 n2 --- IN BLK ) ( anything *** nothing )
	3358	+* ERROR if top two are unequal.
	3359	+* MESSAGE says compiled conditionals do not match.
	3360	+ FCB $86
	3361	+ FCC '?PAIR' ; '?PAIRS'
	3362	+ FCB $D3
	3363	+ FDB QEXEC-8
	3364	+QPAIRS FDB DOCOL,SUB,LIT8
	3365	+ FCB $13
	3366	+ FDB QERR
	3367	+ FDB SEMIS
	3368	+*
	3369	+* ======>> 109 <<
	3370	+* CSP and parameter stack are balanced (equal):
	3371	+* ( --- ) ( *** )
	3372	+* CSP and parameter stack are not balanced (unequal):
	3373	+* ( --- IN BLK ) ( anything *** nothing )
	3374	+* ERROR if return/control stack is not at same level as last !CSP.
	3375	+* Usually indicates that a definition has been left incomplete.
	3376	+ FCB $84
	3377	+ FCC '?CS' ; '?CSP'
	3378	+ FCB $D0
	3379	+ FDB QPAIRS-9
	3380	+QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8
	3381	+ FCB $14
	3382	+ FDB QERR
	3383	+ FDB SEMIS
	3384	+*
	3385	+* ======>> 110 <<
	3386	+* Active BLK input:
	3387	+* ( --- ) ( *** )
	3388	+* No active BLK input:
	3389	+* ( --- IN BLK ) ( anything *** nothing )
	3390	+* ERROR if not loading, i. e., if BLK is zero.
	3391	+ FCB $88
	3392	+ FCC '?LOADIN' ; '?LOADING'
	3393	+ FCB $C7
	3394	+ FDB QCSP-7
	3395	+QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8
	3396	+ FCB $16
	3397	+ FDB QERR
	3398	+ FDB SEMIS
	3399	+*
	3400	+* ######>> screen 41 <<
	3401	+* ======>> 111 <<
	3402	+* ( --- )
	3403	+* Compile an in-line literal value from the instruction stream.
	3404	+ FCB $87
	3405	+ FCC 'COMPIL' ; 'COMPILE'
	3406	+ FCB $C5
	3407	+ FDB QLOAD-11
	3408	+* COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
	3409	+* COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
	3410	+COMPIL FDB DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
	3411	+ FDB SEMIS
	3412	+*
	3413	+* ======>> 112 <<
	3414	+* ( --- ) P
	3415	+* Clear the compile state bit(s) (shift to interpret).
	3416	+ FCB $C1 [ immediate
	3417	+ FCB $DB
	3418	+ FDB COMPIL-10
	3419	+LBRAK FDB DOCOL,ZERO,STATE,STORE
	3420	+ FDB SEMIS
	3421	+*
	3422	+* ======>> 113 <<
	3423	+*
	3424	+STCOMP EQU $C0
	3425	+* ( --- )
	3426	+* Set the compile state bit(s) (shift to compile).
	3427	+ FCB $81 ]
	3428	+ FCB $DD
	3429	+ FDB LBRAK-4
	3430	+RBRAK FDB DOCOL,LIT8
	3431	+ FCB STCOMP
	3432	+ FDB STATE,STORE
	3433	+ FDB SEMIS
	3434	+*
	3435	+* ======>> 114 <<
	3436	+* ( --- )
	3437	+* Toggle SMUDGE bit of LATEST definition header,
	3438	+* to hide it until defined or reveal it after definition.
	3439	+ FCB $86
	3440	+ FCC 'SMUDG' ; 'SMUDGE'
	3441	+ FCB $C5
	3442	+ FDB RBRAK-4
	3443	+SMUDGE FDB DOCOL,LATEST,LIT8
	3444	+ FCB FSMUDG
	3445	+ FDB TOGGLE
	3446	+ FDB SEMIS
	3447	+*
	3448	+* ======>> 115 <<
	3449	+* ( --- )
	3450	+* Set the conversion base to sixteen (b00010000).
	3451	+ FCB $83
	3452	+ FCC 'HE' ; 'HEX'
	3453	+ FCB $D8
	3454	+ FDB SMUDGE-9
	3455	+HEX FDB DOCOL
	3456	+ FDB LIT8
	3457	+ FCB 16 ; decimal sixteen
	3458	+ FDB BASE,STORE
	3459	+ FDB SEMIS
	3460	+*
	3461	+* ======>> 116 <<
	3462	+* ( --- )
	3463	+* Set the conversion base to ten (b00001010).
	3464	+ FCB $87
	3465	+ FCC 'DECIMA' ; 'DECIMAL'
	3466	+ FCB $CC
	3467	+ FDB HEX-6
	3468	+DEC FDB DOCOL
	3469	+ FDB LIT8
	3470	+ FCB 10 ; decimal ten
	3471	+ FDB BASE,STORE
	3472	+ FDB SEMIS
	3473	+*
	3474	+* ######>> screen 42 <<
	3475	+* ======>> 117 <<
	3476	+* ( --- ) ( IP *** )
	3477	+* Pop the saved IP and use it to
	3478	+* compile the latest symbol as a reference to a ;CODE definition;
	3479	+* overwrite the code field of the symbol found by LATEST
	3480	+* with the address of the low-level characteristic code
	3481	+* provided in the defining definition.
	3482	+* Look closely at where things return, consider the operation of R> and >R .
	3483	+*
	3484	+* The machine-level code which follows (;CODE) in the instruction stream
	3485	+* is not executed by the defining symbol,
	3486	+* but becomes the characteristic of the defined symbol.
	3487	+* This is the usual way to generate the characteristics of VARIABLEs,
	3488	+* CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
	3489	+*
	3490	+* Finally, note that, if code shifts from low level back to high
	3491	+* (native CPU machine code calling into a list of FORTH codes),
	3492	+* the low level code can't just call a high-level definition.
	3493	+* Leaf definitions can directly call other leaf definitions,
	3494	+* but not non-leafs.
	3495	+* It will need an anonymous list, probably embedded in the low-level code,
	3496	+* and Y and X will have to be set appropriately before entering the list.
	3497	+ FCB $87
	3498	+ FCC '(;CODE' ; '(;CODE)'
	3499	+ FCB $A9
	3500	+ FDB DEC-10
	3501	+* PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
	3502	+PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
	3503	+ FDB LATEST,PFA,CFA,STORE
	3504	+ FDB SEMIS
	3505	+*
	3506	+* ======>> 118 <<
	3507	+* ( --- ) P
	3508	+* ?CSP to see if there are loose ends in the defining definition
	3509	+* before shifting to the assembler,
	3510	+* compile (;CODE) in the defining definition's instruction stream,
	3511	+* shift to interpreting,
	3512	+* make the ASSEMBLER vocabulary current,
	3513	+* and !CSP to mark the stack
	3514	+* in preparation for assembling low-level code.
	3515	+* Note that ;CODE, unlike DOES>, is IMMEDIATE,
	3516	+* and compiles (;CODE),
	3517	+* which will do the actual work of changing
	3518	+* the LATEST definition's characteristic when the defining word runs.
	3519	+* Assembly is done by the interpreter, rather than the compiler.
	3520	+* I could have avoided the anomalous three-byte code fields by
	3521	+*
	3522	+* Note that the ASSEMBLER is not part of the model (at this time).
	3523	+* That means that, until the assembler is ready,
	3524	+* if you want to define low-level words,
	3525	+* you have to poke (comma) in hand-assembled stuff.
	3526	+*
	3527	+ FCB $C5 immediate
	3528	+ FCC ';COD' ; ';CODE'
	3529	+ FCB $C5
	3530	+ FDB PSCODE-10
	3531	+SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
	3532	+ FDB SEMIS
	3533	+* note: "QSTACK" will be replaced by "ASSEMBLER" later
	3534	+*
	3535	+* ######>> screen 43 <<
	3536	+* ======>> 119 <<
	3537	+* ( --- ) C
	3538	+* Make the word currently being defined
	3539	+* build a header for DOES> definitions.
	3540	+* Actually just compiles a CONSTANT zero
	3541	+* which can be overwritten later by DOES>.
	3542	+* Since the fig models were established, this technique has been deprecated.
	3543	+*
	3544	+* Note that <BUILDS is not IMMEDIATE,
	3545	+* and therefore executes during a definition's run-time,
	3546	+* rather than its compile-time.
	3547	+* It is not intended to be used directly,
	3548	+* but rather so that one definition word can build another.
	3549	+* Also, note that nothing particularly special happens
	3550	+* in the defining definition until DOES> executes.
	3551	+* The name <BUILDS is intended to be a reminder of what is about to occur.
	3552	+*
	3553	+* <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
	3554	+ FCB $87
	3555	+ FCC '<BUILD' ; '<BUILDS'
	3556	+ FCB $D3
	3557	+ FDB SEMIC-8
	3558	+BUILDS FDB DOCOL,ZERO,CON
	3559	+ FDB SEMIS
	3560	+*
	3561	+* ======>> 120 <<
	3562	+* ( --- ) ( IP *** ) C
	3563	+* Define run-time behavior of definitions compiled/defined
	3564	+* by a high-level defining definition --
	3565	+* the FORTH equivalent of a compiler-compiler.
	3566	+* DOES> assumes that the LATEST symbol table entry
	3567	+* has at least one word of parameter field,
	3568	+* which <BUILDS provides.
	3569	+* Note that DOES> is also not IMMEDIATE.
	3570	+*
	3571	+* When the defining word containing DOES> executes the DOES> icode,
	3572	+* it overwrites the LATEST symbol's CFA with jsr <XDOES,
	3573	+* overwrites the first word of that symbol's parameter field with its own IP,
	3574	+* and pops the previous IP from the return stack.
	3575	+* The icodes which follow DOES> in the stream
	3576	+* do not execute at the defining word's run-time.
	3577	+*
	3578	+* Examining XDOES in the virtual machine shows
	3579	+* that the defined word will execute those icodes
	3580	+* which follow DOES> at its own run-time.
	3581	+*
	3582	+* The advantage of this kind of behaviour,
	3583	+* which you will also note in ;CODE,
	3584	+* is that the defined word can contain
	3585	+* both operations and data to be operated on.
	3586	+* This is how FORTH data objects define their own behavior.
	3587	+*
	3588	+* Finally, note that the effective parameter field for DOES> definitions
	3589	+* starts two NATWID words after the CFA, instead of just one
	3590	+* (four bytes instead of two in a sixteen-bit addressing Forth).
	3591	+*
	3592	+* VOCABULARYs will use this. See definition of word FORTH.
	3593	+ FCB $85
	3594	+ FCC 'DOES' ; 'DOES>'
	3595	+ FCB $BE
	3596	+ FDB BUILDS-10
	3597	+* DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
	3598	+DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
	3599	+ FDB LATEST,PFA,STORE
	3600	+ FDB PSCODE
	3601	+*
	3602	+* ( --- PFA+NATWID ) ( *** IP )
	3603	+* Characteristic of a DOES> defined word.
	3604	+* The characteristics of DOES> definitions are written in high-level
	3605	+* Forth codes rather than native CPU machine level code.
	3606	+* The first parameter word points to the high-level characteristic.
	3607	+* This routine's job is to push the IP,
	3608	+* load the high level characteristic pointer in IP,
	3609	+* and leave the address following the characteristic pointer on the stack
	3610	+* so the parameter field can be accessed.
	3611	+DODOES LDD ,S ; Keep the return address.
	3612	+ STY ,S ; Save/nest the current IP on the return stack.
	3613	+ LDY NATWID,X ; First parameter is new IP.
	3614	+ LEAX 2*NATWID,X ; Address of second parameter.
	3615	+ PSHU X
	3616	+ TFR D,PC ; Synthetic return.
	3617	+*
	3618	+* From the 6800 model:
	3619	+* DODOES LDA IP
	3620	+* LDB IP+1
	3621	+* LDX RP make room on return stack
	3622	+* LEAX -1,X ;
	3623	+* LEAX -1,X ;
	3624	+* STX RP
	3625	+* STA 2,X push return address
	3626	+* STB 3,X
	3627	+* LDX W get addr of pointer to run-time code
	3628	+* LEAX 1,X ;
	3629	+* LEAX 1,X ;
	3630	+* STX N stash it in scratch area
	3631	+* LDX 0,X get new IP
	3632	+* STX IP
	3633	+* CLRA ; get address of parameter
	3634	+* LDB #2
	3635	+* ADDB N+1
	3636	+* ADCA N
	3637	+* PSHS B ; and push it on data stack
	3638	+* PSHS A ;
	3639	+* JMP NEXT2
	3640	+*
	3641	+* ######>> screen 44 <<
	3642	+* ======>> 121 <<
	3643	+* ( strptr --- strptr+1 count )
	3644	+* Convert counted string to string and count.
	3645	+* (Fetch the byte at strptr, post-increment.)
	3646	+ FCB $85
	3647	+ FCC 'COUN' ; 'COUNT'
	3648	+ FCB $D4
	3649	+ FDB DOES-8
	3650	+COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
	3651	+ FDB SEMIS
	3652	+*
	3653	+* ======>> 122 <<
	3654	+* ( strptr count --- )
	3655	+* EMIT count characters at strptr.
	3656	+ FCB $84
	3657	+ FCC 'TYP' ; 'TYPE'
	3658	+ FCB $C5
	3659	+ FDB COUNT-8
	3660	+TYPE FDB DOCOL,DDUP,ZBRAN
	3661	+ FDB TYPE3-*-NATWID
	3662	+ FDB OVER,PLUS,SWAP,XDO
	3663	+TYPE2 FDB I,CAT,EMIT,XLOOP
	3664	+ FDB TYPE2-*-NATWID
	3665	+ FDB BRAN
	3666	+ FDB TYPE4-*-NATWID
	3667	+TYPE3 FDB DROP
	3668	+TYPE4 FDB SEMIS
	3669	+*
	3670	+* ======>> 123 <<
	3671	+* ( strptr count1 --- strptr count2 )
	3672	+* Supress trailing blanks (subtract count of trailing blanks from strptr).
	3673	+ FCB $89
	3674	+ FCC '-TRAILIN' ; '-TRAILING'
	3675	+ FCB $C7
	3676	+ FDB TYPE-7
	3677	+DTRAIL FDB DOCOL,DUP,ZERO,XDO
	3678	+DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
	3679	+ FDB SUB,ZBRAN
	3680	+ FDB DTRAL3-*-NATWID
	3681	+ FDB LEAVE,BRAN
	3682	+ FDB DTRAL4-*-NATWID
	3683	+DTRAL3 FDB ONE,SUB
	3684	+DTRAL4 FDB XLOOP
	3685	+ FDB DTRAL2-*-NATWID
	3686	+ FDB SEMIS
	3687	+*
	3688	+* ======>> 124 <<
	3689	+* ( --- )
	3690	+* TYPE counted string out of instruction stream (updating IP).
	3691	+ FCB $84
	3692	+ FCC '(."' ; '(.")'
	3693	+ FCB $A9
	3694	+ FDB DTRAIL-12
	3695	+* PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
	3696	+* PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
	3697	+PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP
	3698	+ FDB FROMR,PLUS,TOR,TYPE
	3699	+ FDB SEMIS
	3700	+*
	3701	+* ======>> 125 <<
	3702	+* ( --- ) P
	3703	+* { ." something-to-be-printed " } typical input
	3704	+* Use WORD to parse to trailing quote;
	3705	+* if compiling, compile XDOTQ and string parsed,
	3706	+* otherwise, TYPE string.
	3707	+ FCB $C2 immediate
	3708	+ FCC '.' ; '."'
	3709	+ FCB $A2
	3710	+ FDB PDOTQ-7
	3711	+DOTQ FDB DOCOL
	3712	+ FDB LIT8
	3713	+ FCB $22 ascii quote
	3714	+ FDB STATE,AT,ZBRAN
	3715	+ FDB DOTQ1-*-NATWID
	3716	+ FDB COMPIL,PDOTQ,WORD
	3717	+ FDB HERE,CAT,ONEP,ALLOT,BRAN
	3718	+ FDB DOTQ2-*-NATWID
	3719	+DOTQ1 FDB WORD,HERE,COUNT,TYPE
	3720	+DOTQ2 FDB SEMIS
	3721	+*
	3722	+* ######>> screen 45 <<
	3723	+* ======>> 126 <<== MACHINE DEPENDENT
	3724	+* ( --- ) ( *** )
	3725	+* ( --- IN BLK ) ( anything *** nothing )
	3726	+* ERROR if parameter stack out of bounds.
	3727	+*
	3728	+* But checking whether the stack is in bounds or not
	3729	+* really should not use the stack.
	3730	+* And there really should be a ?RSTACK, as well.
	3731	+ FCB $86
	3732	+ FCC '?STAC' ; '?STACK'
	3733	+ FCB $CB
	3734	+ FDB DOTQ-5
	3735	+QSTACK FDB DOCOL,LIT8
	3736	+* FCB $12
	3737	+ FCB SINIT-ORIG
	3738	+* But why use that instead of XSPZER (S0)?
	3739	+* Multi-user or multi-tasking would not want that.
	3740	+* CMPU <XSPZER
	3741	+* FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
	3742	+ FDB PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
	3743	+ FDB QERR
	3744	+* prints 'empty stack'
	3745	+*
	3746	+QSTAC2 FDB SPAT
	3747	+* Here, we compare with a value at least 128
	3748	+* higher than dict. ptr. (DICTPT)
	3749	+ FDB HERE,LIT8
	3750	+ FCB $80 ; This is a rough check anyway, leave it as is.
	3751	+ FDB PLUS,LESS,ZBRAN
	3752	+ FDB QSTAC3-*-NATWID
	3753	+ FDB TWO ; NOT the NATWID constant!
	3754	+ FDB QERR
	3755	+* prints 'full stack'
	3756	+*
	3757	+QSTAC3 FDB SEMIS
	3758	+*
	3759	+* ======>> 127 << this word's function
	3760	+* is done by ?STACK in this version
	3761	+* FCB $85
	3762	+* FCC 4,?FREE
	3763	+* FCB $C5
	3764	+* FDB QSTACK-9
	3765	+*QFREE FDB DOCOL,SPAT,HERE,LIT8
	3766	+* FCB $80
	3767	+* FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
	3768	+*
	3769	+* ######>> screen 46 <<
	3770	+* ======>> 128 <<
	3771	+* ( buffer n --- )
	3772	+* ***** Check that this is how it works here:
	3773	+* Get up to n-1 characters from the keyboard,
	3774	+* storing at buffer and echoing, with backspace editing,
	3775	+* quitting when a CR is read.
	3776	+* Terminate it with a NUL.
	3777	+ FCB $86
	3778	+ FCC 'EXPEC' ; 'EXPECT'
	3779	+ FCB $D4
	3780	+ FDB QSTACK-9
	3781	+EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
	3782	+* EXPEC2 FDB KEY,DUP,LIT8
	3783	+EXPEC2 FDB KEY
	3784	+* FDB LIT,$1C,SHOTOS ; DBG
	3785	+ FDB DUP,LIT8
	3786	+ FCB BACKSP-ORIG
	3787	+ FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing
	3788	+ FDB EXPEC3-*-NATWID
	3789	+ FDB DROP,LIT8
	3790	+ FCB 8 ( backspace character to emit )
	3791	+ FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
	3792	+ FDB TOR,SUB,BRAN
	3793	+ FDB EXPEC6-*-NATWID
	3794	+EXPEC3 FDB DUP,LIT8
	3795	+ FCB $D ( carriage return )
	3796	+ FDB EQUAL,ZBRAN
	3797	+ FDB EXPEC4-*-NATWID
	3798	+ FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
	3799	+ FDB EXPEC5-*-NATWID
	3800	+EXPEC4 FDB DUP
	3801	+EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
	3802	+EXPEC6 FDB EMIT,XLOOP
	3803	+ FDB EXPEC2-*-NATWID
	3804	+ FDB DROP
	3805	+ FDB SEMIS
	3806	+*
	3807	+* ======>> 129 <<
	3808	+* ( --- )
	3809	+* EXPECT 128 (TWID) characters to TIB.
	3810	+ FCB $85
	3811	+ FCC 'QUER' ; 'QUERY'
	3812	+ FCB $D9
	3813	+ FDB EXPECT-9
	3814	+QUERY FDB DOCOL,TIB,AT,COLUMS
	3815	+ FDB AT,EXPECT,ZERO,IN,STORE
	3816	+ FDB SEMIS
	3817	+*
	3818	+* ======>> 130 <<
	3819	+* ( --- ) P
	3820	+* End interpretation of a line or screen, and/or prepare for a new block.
	3821	+* Note that the name of this definition is an empty string,
	3822	+* so it matches on the terminating NUL in the terminal or block buffer.
	3823	+ FCB $C1 immediate < carriage return >
	3824	+ FCB $80
	3825	+ FDB QUERY-8
	3826	+NULL FDB DOCOL,BLK,AT,ZBRAN
	3827	+ FDB NULL2-*-NATWID
	3828	+ FDB ONE,BLK,PSTORE
	3829	+ FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
	3830	+ FDB ZEQU
	3831	+* check for end of screen
	3832	+ FDB ZBRAN
	3833	+ FDB NULL1-*-NATWID
	3834	+ FDB QEXEC,FROMR,DROP
	3835	+NULL1 FDB BRAN
	3836	+ FDB NULL3-*-NATWID
	3837	+NULL2 FDB FROMR,DROP
	3838	+NULL3 FDB SEMIS
	3839	+*
	3840	+* ######>> screen 47 <<
	3841	+* ======>> 133 <<
	3842	+* ( adr n b --- )
	3843	+* Fill n bytes at adr with b.
	3844	+* This relies on CMOVE having a certain lack of parameter checking,
	3845	+* where overlapping regions are not properly inverted in copy.
	3846	+* And this really should be done in low-level.
	3847	+* None of the advantages of doing things in high-level apply to fill.
	3848	+ FCB $84
	3849	+ FCC 'FIL' ; 'FILL'
	3850	+ FCB $CC
	3851	+ FDB NULL-4
	3852	+FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
	3853	+ FDB FROMR,ONE,SUB,CMOVE
	3854	+ FDB SEMIS
	3855	+*
	3856	+* ======>> 134 <<
	3857	+* ( adr n --- )
	3858	+* Fill n bytes with 0.
	3859	+ FCB $85
	3860	+ FCC 'ERAS' ; 'ERASE'
	3861	+ FCB $C5
	3862	+ FDB FILL-7
	3863	+ERASE FDB DOCOL,ZERO,FILL
	3864	+ FDB SEMIS
	3865	+*
	3866	+* ======>> 135 <<
	3867	+* ( adr n --- )
	3868	+* Fill n bytes with ASCII SPACE.
	3869	+ FCB $86
	3870	+ FCC 'BLANK' ; 'BLANKS'
	3871	+ FCB $D3
	3872	+ FDB ERASE-8
	3873	+BLANKS FDB DOCOL,BL,FILL
	3874	+ FDB SEMIS
	3875	+*
	3876	+* ======>> 136 <<
	3877	+* ( c --- )
	3878	+* Format a character at the left of the HLD output buffer.
	3879	+ FCB $84
	3880	+ FCC 'HOL' ; 'HOLD'
	3881	+ FCB $C4
	3882	+ FDB BLANKS-9
	3883	+HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
	3884	+ FDB SEMIS
	3885	+*
	3886	+* ======>> 137 <<
	3887	+* ( --- adr )
	3888	+* Give the address of the output PAD buffer.
	3889	+* PAD points to the end of a 68 byte buffer for numeric conversion.
	3890	+ FCB $83
	3891	+ FCC 'PA' ; 'PAD'
	3892	+ FCB $C4
	3893	+ FDB HOLD-7
	3894	+PAD FDB DOCOL,HERE,LIT8
	3895	+ FCB $44
	3896	+ FDB PLUS
	3897	+ FDB SEMIS
	3898	+*
	3899	+* ######>> screen 48 <<
	3900	+* ======>> 138 <<
	3901	+* ( c --- )
	3902	+* Scan a string terminated by the character c or ASCII NUL out of input;
	3903	+* store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
	3904	+* Leading c are passed over, per ENCLOSE.
	3905	+* Scans from BLK, or from TIB if BLK is zero.
	3906	+* May overwrite the numeric conversion pad,
	3907	+* if really long (length > 31) symbols are scanned.
	3908	+ FCB $84
	3909	+ FCC 'WOR' ; 'WORD'
	3910	+ FCB $C4
	3911	+ FDB PAD-6
	3912	+WORD FDB DOCOL,BLK,AT,ZBRAN
	3913	+ FDB WORD2-*-NATWID
	3914	+ FDB BLK,AT,BLOCK,BRAN
	3915	+ FDB WORD3-*-NATWID
	3916	+WORD2 FDB TIB,AT
	3917	+WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
	3918	+ FCB 34
	3919	+ FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
	3920	+ FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
	3921	+ FDB SEMIS
	3922	+*
	3923	+* ######>> screen 49 <<
	3924	+* ======>> 139 <<
	3925	+* ( d1 string --- d2 adr )
	3926	+* Convert the text at string into a number, accumulating the result into d1,
	3927	+* leaving adr pointing to the first character not converted.
	3928	+* If DPL is non-negative at entry,
	3929	+* accumulates the number of characters converted into DPL.
	3930	+ FCB $88
	3931	+ FCC '(NUMBER' ; '(NUMBER)'
	3932	+ FCB $A9
	3933	+ FDB WORD-7
	3934	+PNUMB FDB DOCOL
	3935	+PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
	3936	+ FDB PNUMB4-*-NATWID
	3937	+ FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
	3938	+ FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
	3939	+ FDB PNUMB3-*-NATWID
	3940	+ FDB ONE,DPL,PSTORE
	3941	+PNUMB3 FDB FROMR,BRAN
	3942	+ FDB PNUMB2-*-NATWID
	3943	+PNUMB4 FDB FROMR
	3944	+ FDB SEMIS
	3945	+*
	3946	+* ======>> 140 <<
	3947	+* ( ctstr --- d )
	3948	+* Convert text at ctstr to a double integer,
	3949	+* taking the 0 ERROR if the conversion is not valid.
	3950	+* If a decimal point is present,
	3951	+* accumulate the count of digits to the decimal point's right into DPL
	3952	+* (negative DPL at exit indicates single precision).
	3953	+* ctstr is a counted string
	3954	+* -- the first byte at ctstr is the length of the string,
	3955	+* but NUMBER ignores the count and expects a NUL terminator instead.
	3956	+ FCB $86
	3957	+ FCC 'NUMBE' ; 'NUMBER'
	3958	+ FCB $D2
	3959	+ FDB PNUMB-11
	3960	+NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
	3961	+ FCC "-" minus sign
	3962	+ FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
	3963	+NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
	3964	+ FDB ZBRAN
	3965	+ FDB NUMB2-*-NATWID
	3966	+ FDB DUP,CAT,LIT8
	3967	+ FCC "."
	3968	+ FDB SUB,ZERO,QERR,ZERO,BRAN
	3969	+ FDB NUMB1-*-NATWID
	3970	+NUMB2 FDB DROP,FROMR,ZBRAN
	3971	+ FDB NUMB3-*-NATWID
	3972	+ FDB DMINUS
	3973	+NUMB3 FDB SEMIS
	3974	+*
	3975	+* ======>> 141 <<
	3976	+* ( --- locptr length true ) { -FIND name } typical input
	3977	+* ( --- false )
	3978	+* Parse a word, then FIND,
	3979	+* first in the definition vocabulary,
	3980	+* then in the CONTEXT (interpretation) vocabulary, if necessary.
	3981	+* Returns what (FIND) returns, flag and optional location and length.
	3982	+ FCB $85
	3983	+ FCC '-FIN' ; '-FIND'
	3984	+ FCB $C4
	3985	+ FDB NUMB-9
	3986	+DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
	3987	+ FDB PFIND,DUP,ZEQU,ZBRAN
	3988	+ FDB DFIND2-*-NATWID
	3989	+ FDB DROP,HERE,LATEST,PFIND
	3990	+DFIND2 FDB SEMIS
	3991	+*
	3992	+* ######>> screen 50 <<
	3993	+* ======>> 142 <<
	3994	+* ( anything --- nothing ) ( anything *** nothing )
	3995	+* An indirection for ABORT, for ERROR,
	3996	+* which may be modified carefully.
	3997	+ FCB $87
	3998	+ FCC '(ABORT' ; '(ABORT)'
	3999	+ FCB $A9
	4000	+ FDB DFIND-8
	4001	+PABORT FDB DOCOL,ABORT
	4002	+ FDB SEMIS
	4003	+*
	4004	+* ======>> 143 <<
	4005	+ FCB $85
	4006	+ FCC 'ERRO' ; 'ERROR'
	4007	+ FCB $D2
	4008	+ FDB PABORT-10
	4009	+* This really should not be high level, according to best practices.
	4010	+* But fixing that cascades through MESSAGE,
	4011	+* requiring re-architecting the disk block system.
	4012	+* First, we need to get this transliteration running.
	4013	+ERROR FDB DOCOL,WARN,AT,ZLESS
	4014	+ FDB ZBRAN
	4015	+ FDB ERROR2-*-NATWID
	4016	+* note: WARNING is
	4017	+* -1 to abort,
	4018	+* 0 to print error #
	4019	+* and 1 to print error message from disc
	4020	+ FDB PABORT
	4021	+ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
	4022	+ FCB 4,7 ( bell )
	4023	+ FCC " ? "
	4024	+ FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
	4025	+ FDB SEMIS
	4026	+*
	4027	+* ======>> 144 <<
	4028	+* ( n adr --- )
	4029	+* Mask byte at adr with n.
	4030	+* Not in FIG, don't need it for 8 bit characters after all.
	4031	+* FCB $85
	4032	+* FCC 'CMAS' ; 'CMASK'
	4033	+* FCB $CB ; 'K'
	4034	+* FDB ERROR-8
	4035	+* CMASK FDB *+NATWID
	4036	+* LDX ,U++ ; adr
	4037	+* LDD ,U++ ; mask
	4038	+* ANDB ,X
	4039	+* STB ,X
	4040	+* RTS
	4041	+*
	4042	+* ( adr --- adr )
	4043	+* Mask high bit of tail of name in PAD buffer.
	4044	+* Not in FIG, need it for 8 bit characters.
	4045	+ FCB $86
	4046	+ FCC 'IDFLA' ; 'IDFLAT'
	4047	+ FCB $D4 ; 'T'
	4048	+ FDB ERROR-8
	4049	+IDFLAT FDB *+NATWID
	4050	+ LDX ,U
	4051	+ LDB ,X ; get the count
	4052	+ ANDB #CTMASK
	4053	+ LDA B,X ; point to the tail
	4054	+ ANDA #$7F ; Clear the EndOfName flag bit.
	4055	+ STA B,X
	4056	+ RTS
	4057	+*
	4058	+* ( symptr --- )
	4059	+* Print definition's name from its NFA.
	4060	+ FCB $83
	4061	+ FCC 'ID' ; 'ID.'
	4062	+ FCB $AE
	4063	+ FDB IDFLAT-9
	4064	+IDDOT FDB DOCOL,PAD,LIT8
	4065	+ FCB 32
	4066	+ FDB LIT8
	4067	+ FCB $5F ( underline )
	4068	+ FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
	4069	+* FDB SWAP,CMOVE,PAD,COUNT,LIT8
	4070	+ FDB SWAP,CMOVE,PAD
	4071	+ FDB IDFLAT
	4072	+ FDB COUNT,LIT8
	4073	+ FCB 31
	4074	+ FDB AND,TYPE,SPACE
	4075	+ FDB SEMIS
	4076	+*
	4077	+* ######>> screen 51 <<
	4078	+* ======>> 145 <<
	4079	+* ( --- ) { CREATE name } input
	4080	+* Parse a name (length < 32 characters) and create a header,
	4081	+* reporting first duplicate found in either the defining vocabulary
	4082	+* or the context (interpreting) vocabulary.
	4083	+* Install the header in the defining vocabulary
	4084	+* with CFA dangerously pointing to the parameter field.
	4085	+* Leave the name SMUDGEd.
	4086	+ FCB $86
	4087	+ FCC 'CREAT' ; 'CREATE'
	4088	+ FCB $C5
	4089	+ FDB IDDOT-6
	4090	+CREATE FDB DOCOL,DFIND,ZBRAN
	4091	+ FDB CREAT2-*-NATWID
	4092	+ FDB DROP,PDOTQ
	4093	+ FCB 8
	4094	+ FCB 7 ( bel )
	4095	+ FCC "redef: "
	4096	+ FDB NFA,IDDOT,LIT8
	4097	+ FCB 4
	4098	+ FDB MESS,SPACE
	4099	+CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
	4100	+ FDB ONEP,ALLOT,DUP,LIT8
	4101	+ FCB ($80\|FSMUDG) ; Bracket the name.
	4102	+ FDB TOGGLE,HERE,ONE,SUB,LIT8
	4103	+ FCB $80
	4104	+ FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
	4105	+* FDB HERE,TWOP,COMMA
	4106	+ FDB HERE,NATP,COMMA
	4107	+ FDB SEMIS
	4108	+*
	4109	+* ######>> screen 52 <<
	4110	+* ======>> 146 <<
	4111	+* ( --- ) P
	4112	+* { [COMPILE] name } typical use
	4113	+* -DFIND next WORD and COMPILE it, literally;
	4114	+* used to compile immediate definitions into words.
	4115	+ FCB $C9 immediate
	4116	+ FCC '[COMPILE' ; '[COMPILE]'
	4117	+ FCB $DD
	4118	+ FDB CREATE-9
	4119	+BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
	4120	+ FDB SEMIS
	4121	+*
	4122	+* ======>> 147 <<
	4123	+* ( n --- ) if compiling. P
	4124	+* ( n --- n ) if interpreting.
	4125	+* Compile n as a literal, if compiling.
	4126	+ FCB $C7 immediate
	4127	+ FCC 'LITERA' ; 'LITERAL'
	4128	+ FCB $CC
	4129	+ FDB BCOMP-12
	4130	+LITER FDB DOCOL,STATE,AT,ZBRAN
	4131	+ FDB LITER2-*-NATWID
	4132	+ FDB COMPIL,LIT,COMMA
	4133	+LITER2 FDB SEMIS
	4134	+*
	4135	+* ======>> 148 <<
	4136	+* ( d --- ) if compiling. P
	4137	+* ( d --- d ) if interpreting.
	4138	+* Compile d as a double literal, if compiling.
	4139	+ FCB $C8 immediate
	4140	+ FCC 'DLITERA' ; 'DLITERAL'
	4141	+ FCB $CC
	4142	+ FDB LITER-10
	4143	+DLITER FDB DOCOL,STATE,AT,ZBRAN
	4144	+ FDB DLITE2-*-NATWID
	4145	+ FDB SWAP,LITER,LITER ; Just two literals in the right order.
	4146	+DLITE2 FDB SEMIS
	4147	+*
	4148	+* ######>> screen 53 <<
	4149	+* ======>> 149 <<
	4150	+* ( --- )
	4151	+* Interpret or compile, according to STATE.
	4152	+* Searches words parsed in dictionary first, via -FIND,
	4153	+* then checks for valid NUMBER.
	4154	+* Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
	4155	+* ERROR checks the stack via ?STACK before returning to its caller.
	4156	+ FCB $89
	4157	+ FCC 'INTERPRE' ; 'INTERPRET'
	4158	+ FCB $D4
	4159	+ FDB DLITER-11
	4160	+INTERP FDB DOCOL
	4161	+INTER2 FDB DFIND,ZBRAN
	4162	+ FDB INTER5-*-NATWID
	4163	+ FDB STATE,AT,LESS
	4164	+ FDB ZBRAN
	4165	+ FDB INTER3-*-NATWID
	4166	+ FDB CFA,COMMA,BRAN
	4167	+ FDB INTER4-*-NATWID
	4168	+INTER3 FDB CFA,EXEC
	4169	+INTER4 FDB BRAN
	4170	+ FDB INTER7-*-NATWID
	4171	+INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
	4172	+ FDB INTER6-*-NATWID
	4173	+ FDB DLITER,BRAN
	4174	+ FDB INTER7-*-NATWID
	4175	+INTER6 FDB DROP,LITER
	4176	+INTER7 FDB QSTACK,BRAN
	4177	+ FDB INTER2-*-NATWID
	4178	+* FDB SEMIS never executed
	4179	+
	4180	+*
	4181	+* ######>> screen 54 <<
	4182	+* ======>> 150 <<
	4183	+* ( --- )
	4184	+* Toggle precedence bit of LATEST definition header.
	4185	+* During compiling, most symbols scanned are compiled.
	4186	+* IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
	4187	+* but may be compiled via ' (TICK).
	4188	+ FCB $89
	4189	+ FCC 'IMMEDIAT' ; 'IMMEDIATE'
	4190	+ FCB $C5
	4191	+ FDB INTERP-12
	4192	+IMMED FDB DOCOL,LATEST,LIT8
	4193	+ FCB FIMMED
	4194	+ FDB TOGGLE
	4195	+ FDB SEMIS
	4196	+*
	4197	+* ======>> 151 <<
	4198	+* ( --- ) { VOCABULARY name } input
	4199	+* Create a vocabulary entry with a flag for terminating vocabulary searches.
	4200	+* Store the current search context in it for linking.
	4201	+* At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
	4202	+ FCB $8A
	4203	+ FCC 'VOCABULAR' ; 'VOCABULARY'
	4204	+ FCB $D9
	4205	+ FDB IMMED-12
	4206	+VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
	4207	+ FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
	4208	+* DOVOC FDB TWOP,CONTXT,STORE
	4209	+DOVOC FDB NATP,CONTXT,STORE
	4210	+ FDB SEMIS
	4211	+*
	4212	+* ======>> 152 <<
	4213	+*
	4214	+* Note: FORTH does not go here in the rom-able dictionary,
	4215	+* since FORTH is a type of variable.
	4216	+*
	4217	+* (Should make a proper architecture for this at some point.)
	4218	+*
	4219	+*
	4220	+* ======>> 153 <<
	4221	+* ( --- )
	4222	+* Makes the current interpretation CONTEXT vocabulary
	4223	+* also the CURRENT defining vocabulary.
	4224	+ FCB $8B
	4225	+ FCC 'DEFINITION' ; 'DEFINITIONS'
	4226	+ FCB $D3
	4227	+ FDB VOCAB-13
	4228	+DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
	4229	+ FDB SEMIS
	4230	+*
	4231	+* ======>> 154 <<
	4232	+* ( --- )
	4233	+* Parse out a comment and toss it away.
	4234	+* Leaves the first 32 characters in WORDPAD, which may or may not be useful.
	4235	+ FCB $C1 immediate (
	4236	+ FCB $A8
	4237	+ FDB DEFIN-14
	4238	+PAREN FDB DOCOL,LIT8
	4239	+ FCC ")"
	4240	+ FDB WORD
	4241	+ FDB SEMIS
	4242	+*
	4243	+* ######>> screen 55 <<
	4244	+* ======>> 155 <<
	4245	+* ( anything *** nothing )
	4246	+* Clear return stack.
	4247	+* Then INTERPRET and, if not compiling, prompt with OK,
	4248	+* in infinite loop.
	4249	+ FCB $84
	4250	+ FCC 'QUI' ; 'QUIT'
	4251	+ FCB $D4
	4252	+ FDB PAREN-4
	4253	+QUIT FDB DOCOL,ZERO,BLK,STORE
	4254	+ FDB LBRAK
	4255	+*
	4256	+* Here is the outer interpretter
	4257	+* which gets a line of input, does it, prints " OK"
	4258	+* then repeats :
	4259	+QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
	4260	+ FDB ZBRAN
	4261	+ FDB QUIT3-*-NATWID
	4262	+ FDB PDOTQ
	4263	+ FCB 3
	4264	+ FCC ' OK' ; ' OK'
	4265	+QUIT3 FDB BRAN
	4266	+ FDB QUIT2-*-NATWID
	4267	+* FDB SEMIS ( never executed )
	4268	+*
	4269	+* ======>> 156 <<
	4270	+* ( anything --- nothing ) ( anything *** nothing )
	4271	+* Clear parameter stack,
	4272	+* set STATE to interpret and BASE to DECIMAL,
	4273	+* return to input from terminal,
	4274	+* restore DRIVE OFFSET to 0,
	4275	+* print out "Forth-68",
	4276	+* set interpret and define vocabularies to FORTH,
	4277	+* and finally, QUIT.
	4278	+* Used to force the system to a known state
	4279	+* and return control to the initial INTERPRETer.
	4280	+ FCB $85
	4281	+ FCC 'ABOR' ; 'ABORT'
	4282	+ FCB $D4
	4283	+ FDB QUIT-7
	4284	+ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
	4285	+ FCB 19
	4286	+ FCC "fig-Forth-6809(RTS)"
	4287	+ FDB FORTH,DEFIN
	4288	+ FDB QUIT
	4289	+* FDB SEMIS never executed
	4290	+ PAGE
	4291	+*
	4292	+* ######>> screen 56 <<
	4293	+* bootstrap code... moves rom contents to ram :
	4294	+* ======>> 157 <<
	4295	+ FCB $84
	4296	+ FCC 'COL' ; 'COLD'
	4297	+ FCB $C4
	4298	+ FDB ABORT-8
	4299	+COLD FDB *+NATWID
	4300	+* Ultimately, we want position indepence,
	4301	+* so I'm using PCR where it seems reasonable.
	4302	+CENT LDS SINIT,PCR ; Get a useable return stack, at least.
	4303	+ LDA #IUPDP ; This is not relative to PC.
	4304	+ TFR A,DP ; And a useable direct page, too.
	4305	+ SETDP IUPDP ; (For good measure.)
	4306	+*
	4307	+* We'll keep this here for the time being.
	4308	+* There are better ways to do this, of course.
	4309	+* Re-architect, re-architect.
	4310	+ LEAX ERAM,PCR ; end of stuff to move
	4311	+ STX <XFENCE ; Borrow this variable for a loop terminator.
	4312	+ LDY #RBEG ; bottom of open-ended destination
	4313	+ LEAX RAM,PCR ; bottom of stuff to move
	4314	+COLD2 LDA ,X+
	4315	+ STA ,Y+ ; move TASK & FORTH to ram
	4316	+ CMPX <XFENCE
	4317	+ BNE COLD2
	4318	+* Leaves USE and PREV uninitialized.
	4319	+ LDX BUFINT,PCR
	4320	+ STX <XUSE
	4321	+ STX <XPREV
	4322	+* LEAX RAM,PCR
	4323	+* STX <XFENCE ; Borrow this variable for a loop terminator.
	4324	+* LEAY REND,PCR ; top of destination (included XUSE and XPREV)
	4325	+* LEAX ERAM,PCR ; top of stuff to move (included initializers for XUSE and XPREV)
	4326	+* COLD2 LDA ,-X
	4327	+* STA ,-Y ; move TASK & FORTH to ram
	4328	+* CMPX <XFENCE
	4329	+* BNE COLD2
	4330	+*
	4331	+* CENT LDS #REND-1 top of destination
	4332	+* LDX #ERAM top of stuff to move
	4333	+* COLD2 LEAX -1,X ;
	4334	+* LDA 0,X
	4335	+* PSHS A ; move TASK & FORTH to ram
	4336	+* CMPX #RAM
	4337	+* BNE COLD2
	4338	+*
	4339	+* LDS #XFENCE-1 put stack at a safe place for now
	4340	+* But that is taken care of.
	4341	+* LDX COLINT
	4342	+* STX XCOLUM
	4343	+ LDX COLINT,PCR
	4344	+ STX <XCOLUM
	4345	+* LDX DELINT
	4346	+* STX XDELAY
	4347	+ LDX DELINT,PCR
	4348	+ STX <XDELAY
	4349	+* LDX VOCINT
	4350	+* STX XVOCL
	4351	+ LDX VOCINT,PCR
	4352	+ STX <XVOCL
	4353	+* LDX DPINIT
	4354	+* STX XDICTP
	4355	+ LDX DPINIT,PCR
	4356	+ STX <XDICTP
	4357	+* LDX FENCIN
	4358	+* STX XFENCE
	4359	+ LDX FENCIN,PCR
	4360	+ STX <XFENCE
	4361	+*
	4362	+WENT LDS SINIT,PCR ; Get a useable return stack, at least.
	4363	+ LDA #IUPDP ; This is not relative to PC.
	4364	+ TFR A,DP ; And a useable direct page, too.
	4365	+ SETDP IUPDP ; (For good measure.)
	4366	+*
	4367	+ LEAX SINIT,PCR
	4368	+ PSHS X ; for loop termination
	4369	+ CLRB ; Yes, I'm being a little ridiculous. Only a little.
	4370	+ TFR D,Y
	4371	+ LEAY XFENCE-UORIG,Y ; top of destination
	4372	+ LEAX FENCIN,PCR ; top of stuff to move
	4373	+WARM2 LDD ,--X ; All entries are 16 bit.
	4374	+ STD ,--Y
	4375	+ CMPX ,S
	4376	+ BNE WARM2
	4377	+ LEAS 2,S ; But we'll reset the return stack shortly, anyway.
	4378	+ LDU <XSPZER ; So we can clear the hole above the TOS
	4379	+* WENT LDS #XFENCE-1 top of destination
	4380	+* LDX #FENCIN top of stuff to move
	4381	+* WARM2 LEAX -1,X ;
	4382	+* LDA 0,X
	4383	+* PSHS A ;
	4384	+* CMPX #SINIT
	4385	+* BNE WARM2
	4386	+*
	4387	+* LDS SINIT
	4388	+* S is already there.
	4389	+* LDX UPINIT
	4390	+* STX UP init user ram pointer
	4391	+* UP is already there (DP).
	4392	+* LDX #ABORT
	4393	+* STX IP
	4394	+ LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
	4395	+*
	4396	+ NOP Here is a place to jump to special user
	4397	+ NOP initializations such as I/0 interrups
	4398	+ NOP
	4399	+*
	4400	+* For systems with TRACE:
	4401	+ LDX #00
	4402	+ STX ,U The hole above the parameter stack
	4403	+* STX TRLIM clear trace mode
	4404	+ STX <TRLIM clear trace mode (both bytes)
	4405	+ LDX #0
	4406	+* STX BRKPT clear breakpoint address
	4407	+ STX <BRKPT clear breakpoint address
	4408	+* JMP RPSTOR+2 start the virtual machine running !
	4409	+ LBSR RPSTOR+NATWID start the virtual machine running !
	4410	+ LEAX WENT,PCR ; But we must also give RP! someplace to return.
	4411	+ STX ,S ; This rail might get walked on by (DO).
	4412	+ LBRA NEXT
	4413	+* RP! sets up the return stack pointer, then Y references abort.
	4414	+*
	4415	+* Here is the stuff that gets copied to ram :
	4416	+* (not * at address $140:)
	4417	+* at an appropriate address:
	4418	+*
	4419	+* RAM FDB $3000,$3000,0,0
	4420	+* RAM FDB BUFBAS,BUFBAS,0,0 ; ... except the direct page has moved.
	4421	+* These initialization values for USE and PREV were here to help pack the code.
	4422	+* They don't belong here unless we move the USER table
	4423	+* back below the writable dictionary,
	4424	+* and move these USER variables to the end of the direct page --
	4425	+* or let these definitions exist in the USER table.
	4426	+RAM EQU *
	4427	+
	4428	+* ======>> (152) <<
	4429	+* ( --- ) P
	4430	+* Makes FORTH the current interpretation vocabulary.
	4431	+* In order to make this ROMmable, this entry is set up as the tail-end,
	4432	+* and copied to RAM in the start-up code.
	4433	+* We want a more elegant solution to this, too. Greedy, maybe.
	4434	+ FCB $C5 immediate
	4435	+ FCC 'FORT' ; 'FORTH'
	4436	+ FCB $C8
	4437	+ FDB NOOP-7 ; Note that this does not link to COLD!
	4438	+RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
	4439	+ FDB 0
	4440	+ FCC "Copyright 1979 Forth Interest Group, David Lion,"
	4441	+ FCB $0D
	4442	+ FCC "Parts Copyright 2019 Joel Matthew Rees"
	4443	+ FCB $0D
	4444	+ FCB $84
	4445	+ FCC 'TAS' ; 'TASK'
	4446	+ FCB $CB
	4447	+ FDB FORTH-8
	4448	+RTASK FDB DOCOL,SEMIS
	4449	+ERAM EQU *
	4450	+ERAMSZ EQU *-RAM ; So we can get a look at it.
	4451	+ PAGE
	4452	+*
	4453	+* ######>> screen 57 <<
	4454	+* ======>> 158 <<
	4455	+* ( n0 --- d0 )
	4456	+* Sign extend n0 to a double integer.
	4457	+ FCB $84
	4458	+ FCC 'S->' ; 'S->D'
	4459	+ FCB $C4
	4460	+ FDB COLD-7 ; Note that this does not link to FORTH (RFORTH)!
	4461	+STOD FDB DOCOL,DUP,ZLESS,MINUS
	4462	+ FDB SEMIS
	4463	+
	4464	+
	4465	+*
	4466	+* ======>> 159 <<
	4467	+* ( multiplier multiplicand --- product )
	4468	+* Signed word multiply.
	4469	+ FCB $81 ; *
	4470	+ FCB $AA
	4471	+ FDB STOD-7
	4472	+STAR FDB *+NATWID
	4473	+ LBSR USTAR+NATWID ; or [USTAR,PCR]?
	4474	+ LEAU NATWID,U ; Drop high word.
	4475	+ RTS
	4476	+* JSR USTARS
	4477	+* LEAS 1,S ;
	4478	+* LEAS 1,S ;
	4479	+* JMP NEXT
	4480	+*
	4481	+* ======>> 160 <<
	4482	+* ( dividend divisor --- remainder quotient )
	4483	+* M/ in word-only form, i. e., signed division of 2nd word by top word,
	4484	+* yielding signed word quotient and remainder.
	4485	+* Except BUG it isn't signed.
	4486	+ FCB $84
	4487	+ FCC '/MO' ; '/MOD'
	4488	+ FCB $C4
	4489	+ FDB STAR-4
	4490	+SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
	4491	+ FDB SEMIS
	4492	+*
	4493	+* ======>> 161 <<
	4494	+* ( dividend divisor --- quotient )
	4495	+* Signed word divide without remainder.
	4496	+* Except BUG it isn't signed.
	4497	+ FCB $81 ; /
	4498	+ FCB $AF
	4499	+ FDB SLMOD-7
	4500	+SLASH FDB DOCOL,SLMOD,SWAP,DROP
	4501	+ FDB SEMIS
	4502	+*
	4503	+* ======>> 162 <<
	4504	+* ( dividend divisor --- remainder )
	4505	+* Remainder function, result takes sign of dividend.
	4506	+ FCB $83
	4507	+ FCC 'MO' ; 'MOD'
	4508	+ FCB $C4
	4509	+ FDB SLASH-4
	4510	+MOD FDB DOCOL,SLMOD,DROP
	4511	+ FDB SEMIS
	4512	+*
	4513	+* ======>> 163 <<
	4514	+* ( multiplier multiplicand divisor --- remainder quotient )
	4515	+* Signed precise division of product:
	4516	+* multiply 2nd and 3rd words on stack
	4517	+* and divide the 31-bit product by the top word,
	4518	+* leaving both quotient and remainder.
	4519	+* Remainder takes sign of product.
	4520	+* Guaranteed not to lose significant bits in 16 bit integer math.
	4521	+ FCB $85
	4522	+ FCC '/MO' ; '/MOD'
	4523	+ FCB $C4
	4524	+ FDB MOD-6
	4525	+SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
	4526	+ FDB SEMIS
	4527	+*
	4528	+* ======>> 164 <<
	4529	+* ( multiplier multiplicand divisor --- quotient )
	4530	+* */MOD without remainder.
	4531	+ FCB $82
	4532	+ FCC '' ; '/'
	4533	+ FCB $AF
	4534	+ FDB SSMOD-8
	4535	+SSLASH FDB DOCOL,SSMOD,SWAP,DROP
	4536	+ FDB SEMIS
	4537	+*
	4538	+* ======>> 165 <<
	4539	+* ( ud1 u1 --- u2 ud2 )
	4540	+* U/ with an (unsigned) double quotient.
	4541	+* Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
	4542	+* if you are prepared to deal with the extra 16 bits of result.
	4543	+ FCB $85
	4544	+ FCC 'M/MO' ; 'M/MOD'
	4545	+ FCB $C4
	4546	+ FDB SSLASH-5
	4547	+MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
	4548	+ FDB FROMR,SWAP,TOR,USLASH,FROMR
	4549	+ FDB SEMIS
	4550	+*
	4551	+* ======>> 166 <<
	4552	+* ( n>=0 --- n )
	4553	+* ( n<0 --- -n )
	4554	+* Convert the top of stack to its absolute value.
	4555	+ FCB $83
	4556	+ FCC 'AB' ; 'ABS'
	4557	+ FCB $D3
	4558	+ FDB MSMOD-8
	4559	+ABS FDB DOCOL,DUP,ZLESS,ZBRAN
	4560	+ FDB ABS2-*-NATWID
	4561	+ FDB MINUS
	4562	+ABS2 FDB SEMIS
	4563	+*
	4564	+* ======>> 167 <<
	4565	+* ( d>=0 --- d )
	4566	+* ( d<0 --- -d )
	4567	+* Convert the top double to its absolute value.
	4568	+ FCB $84
	4569	+ FCC 'DAB' ; 'DABS'
	4570	+ FCB $D3
	4571	+ FDB ABS-6
	4572	+DABS FDB DOCOL,DUP,ZLESS,ZBRAN
	4573	+ FDB DABS2-*-NATWID
	4574	+ FDB DMINUS
	4575	+DABS2 FDB SEMIS
	4576	+*
	4577	+* ######>> screen 58 <<
	4578	+* Disc primitives :
	4579	+* ======>> 168 <<
	4580	+* ( --- vadr )
	4581	+* Least Recently Used buffer.
	4582	+* Really should be with FIRST and LIMIT in the per-task table.
	4583	+ FCB $83
	4584	+ FCC 'US' ; 'USE'
	4585	+ FCB $C5
	4586	+ FDB DABS-7
	4587	+USE FDB DOCON
	4588	+ FDB XUSE
	4589	+* ======>> 169 <<
	4590	+* ( --- vadr )
	4591	+* Most Recently Used buffer.
	4592	+* Really should be with FIRST and LIMIT in the per-task table.
	4593	+ FCB $84
	4594	+ FCC 'PRE' ; 'PREV'
	4595	+ FCB $D6
	4596	+ FDB USE-6
	4597	+PREV FDB DOCON
	4598	+ FDB XPREV
	4599	+* ======>> 170 <<
	4600	+* ( buffer1 --- buffer2 f )
	4601	+* Bump to next buffer,
	4602	+* flag false if result is PREVious buffer,
	4603	+* otherwise flag true.
	4604	+* Used in the LRU allocation routines.
	4605	+ FCB $84
	4606	+ FCC '+BU' ; '+BUF'
	4607	+ FCB $C6
	4608	+ FDB PREV-7
	4609	+* PBUF FDB DOCOL,LIT8
	4610	+* FCB $84 ; This was a hard-wiring bug.
	4611	+PBUF FDB DOCOL,BBUF,BCTL,PLUS ; Size of the buffer record.
	4612	+* FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
	4613	+ FDB PLUS,DUP,LIMIT,LESS,ZEQU,OVER,FIRST,LESS,OR,ZBRAN
	4614	+ FDB PBUF2-*-NATWID ; Use defensive programming.
	4615	+ FDB DROP,FIRST
	4616	+PBUF2 FDB DUP,PREV,AT,SUB
	4617	+ FDB SEMIS
	4618	+*
	4619	+* ======>> 171 <<
	4620	+* ( --- f )
	4621	+* Flag to mark a buffer dirty, in need of being written out.
	4622	+* This flag limits the max number of sectors in a disk to ((256^NATWID)/2)-1.
	4623	+* It also hard-codes an implicit test which is used elsewhere.
	4624	+ FCB $8A
	4625	+ FCC 'UPDATE-BI' ; 'UPDATE-BIT'
	4626	+ FCB $D4
	4627	+ FDB PBUF-7
	4628	+UPDBIT FDB DOCON
	4629	+ FDB $8000
	4630	+*
	4631	+* ( --- )
	4632	+* Mark PREVious buffer dirty, in need of being written out.
	4633	+ FCB $86
	4634	+ FCC 'UPDAT' ; 'UPDATE'
	4635	+ FCB $C5
	4636	+ FDB UPDBIT-13
	4637	+* UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
	4638	+UPDATE FDB DOCOL,PREV,AT,AT,UPDBIT,OR,PREV,AT,STORE
	4639	+ FDB SEMIS
	4640	+*
	4641	+* ======>> 172 <<
	4642	+* ( adr --- )
	4643	+* Mark the buffer addressed as empty.
	4644	+* Have to add code to avoid block 0 appearing to be in a buffer from COLD.
	4645	+* Usually, there is no sector 0 (?), but the RAM buffers are too simple.
	4646	+* Note that without this block number being made illegal,
	4647	+* about 8 binaryMegabytes (256 bytes/block) of disk can be addressed total.
	4648	+* With this block number made illegal, the max is 1 block less,
	4649	+* still about 8 biMeg.
	4650	+ FCB $8B
	4651	+ FCC 'KILL-BUFFE' ; 'KILL-BUFFER'
	4652	+ FCB $D2
	4653	+ FDB UPDATE-9
	4654	+KILBUF FDB *+NATWID ; DOCOL,UPDBIT,ONE,SUB,SWAP,STORE
	4655	+ PULU X
	4656	+ LDD UPDBIT+NATWID,PCR
	4657	+ SUBD #1
	4658	+ STD ,X
	4659	+* LBSR DBGREG
	4660	+ RTS
	4661	+*
	4662	+* ( --- )
	4663	+* Mark all buffers empty.
	4664	+ FCB $8C
	4665	+ FCC 'KILL-BUFFER' ; 'KILL-BUFFERS'
	4666	+ FCB $D3
	4667	+ FDB KILBUF-14
	4668	+KLBFS FDB *+NATWID
	4669	+ LDD #4
	4670	+ PSHU D
	4671	+ LDD FIRST+NATWID,PCR
	4672	+* INC <TRACEM
	4673	+* LBSR DBGREG
	4674	+ PSHU D ; DUP
	4675	+KLBFSL PSHU D
	4676	+ BSR KILBUF+NATWID
	4677	+ LDD ,U
	4678	+* LBSR DBGREG
	4679	+ ADDD BBUF+NATWID,PCR
	4680	+ ADDD BCTL+NATWID,PCR
	4681	+ STD ,U
	4682	+* LBSR DBGREG
	4683	+ DEC NATWID+1,U
	4684	+ BNE KLBFSL
	4685	+* LBSR DBGREG
	4686	+ LEAU NATWID*2,U
	4687	+* DEC <TRACEM
	4688	+ RTS
	4689	+*
	4690	+* ( --- )
	4691	+* Erase and mark all buffers empty.
	4692	+* Standard method of discarding changes.
	4693	+ FCB $8D
	4694	+ FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
	4695	+ FCB $D3
	4696	+ FDB KLBFS-15
	4697	+MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
	4698	+* FDB FIRST,DUP,KILBUF,PBUF,DROP,DUP,KILBUF
	4699	+* FDB PBUF,DROP,DUP,KILBUF,PBUF,DROP,KILBUF
	4700	+ FDB KLBFS
	4701	+ FDB SEMIS
	4702	+*
	4703	+* ======>> 173 <<
	4704	+* ( --- )
	4705	+* Clear the current offset to the block numbers in the drive interface.
	4706	+* The drives need to be re-architected.
	4707	+* Would be cool to have RAM and ROM drives supported
	4708	+* in addition to regular physical persistent store.
	4709	+ FCB $83
	4710	+ FCC 'DR' ; 'DR0'
	4711	+ FCB $B0
	4712	+ FDB MTBUF-16
	4713	+DRZERO FDB DOCOL,ZERO,OFSET,STORE
	4714	+ FDB SEMIS
	4715	+*
	4716	+* ======>> 174 <<== system dependant word
	4717	+* ( --- )
	4718	+* Set the current offset in the drive interface to reference the second drive.
	4719	+* The hard-coded number in there needs to be in a table.
	4720	+ FCB $83
	4721	+ FCC 'DR' ; 'DR1'
	4722	+ FCB $B1
	4723	+ FDB DRZERO-6
	4724	+DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
	4725	+; **** hard-codes the size of the disc !!!!
	4726	+ FDB SEMIS
	4727	+*
	4728	+* ######>> screen 59 <<
	4729	+* ======>> 175 <<
	4730	+* ( n --- buffer )
	4731	+* Get a free buffer,
	4732	+* assign it to block n,
	4733	+* return buffer address.
	4734	+* Will free a buffer by writing it, if necessary.
	4735	+* Does not actually read the block.
	4736	+* A bug in the fig LRU algorithm, which I have not fixed,
	4737	+* gives the PREVious buffer if USE gets set to PREVious.
	4738	+* (The bug is that USE sometimes gets set to PREVious.)
	4739	+* This bug sometimes causes sector moves to become sector fills.
	4740	+ FCB $86
	4741	+ FCC 'BUFFE' ; 'BUFFER'
	4742	+ FCB $D2
	4743	+ FDB DRONE-6
	4744	+BUFFER FDB DOCOL,USE,AT,DUP,TOR
	4745	+BUFFR2 FDB PBUF,ZBRAN
	4746	+ FDB BUFFR2-*-NATWID
	4747	+ FDB USE,STORE,R,AT,ZLESS
	4748	+ FDB ZBRAN
	4749	+ FDB BUFFR3-*-NATWID
	4750	+* FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
	4751	+ FDB R,NATP,R,AT,UPDBIT,LNOT,AND,ZERO,RW
	4752	+* BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
	4753	+BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
	4754	+ FDB SEMIS
	4755	+*
	4756	+* ######>> screen 60 <<
	4757	+* ======>> 176 <<
	4758	+* ( n --- buffer )
	4759	+* Get BUFFER containing block n, relative to OFFSET.
	4760	+* If block n is not in a buffer, bring it in.
	4761	+* Returns buffer address.
	4762	+ FCB $85
	4763	+ FCC 'BLOC' ; 'BLOCK'
	4764	+ FCB $CB
	4765	+ FDB BUFFER-9
	4766	+BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
	4767	+ FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
	4768	+ FDB BLOCK5-*-NATWID
	4769	+BLOCK3 FDB PBUF,ZEQU,ZBRAN
	4770	+ FDB BLOCK4-*-NATWID
	4771	+* FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
	4772	+ FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
	4773	+BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
	4774	+ FDB BLOCK3-*-NATWID
	4775	+ FDB DUP,PREV,STORE
	4776	+* BLOCK5 FDB FROMR,DROP,TWOP
	4777	+BLOCK5 FDB FROMR,DROP,NATP
	4778	+ FDB SEMIS
	4779	+*
	4780	+* ######>> screen 61 <<
	4781	+* ======>> 177 <<
	4782	+* ( line screen --- buffer C/L)
	4783	+* Bring in the sector containing the specified line of the specified screen.
	4784	+* Returns the buffer address and the width of the screen.
	4785	+* Screen number is relative to OFFSET.
	4786	+* The line number may be beyond screen 4,
	4787	+* (LINE) will get the appropriate screen.
	4788	+ FCB $86
	4789	+ FCC '(LINE' ; '(LINE)'
	4790	+ FCB $A9
	4791	+ FDB BLOCK-8
	4792	+PLINE FDB DOCOL,TOR,LIT8
	4793	+ FCB $40
	4794	+ FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
	4795	+ FCB $40
	4796	+ FDB SEMIS
	4797	+*
	4798	+* ======>> 178 <<
	4799	+* ( line screen --- )
	4800	+* Print the line of the screen as found by (LINE), suppress trailing BLANKS.
	4801	+ FCB $85
	4802	+ FCC '.LIN' ; '.LINE'
	4803	+ FCB $C5
	4804	+ FDB PLINE-9
	4805	+DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
	4806	+ FDB SEMIS
	4807	+*
	4808	+* ======>> 179 <<
	4809	+* ( n --- )
	4810	+* If WARNING is 0, print "MESSAGE #n";
	4811	+* otherwise, print line n relative to screen 4,
	4812	+* the line number may be negative.
	4813	+* Uses .LINE, but counter-adjusts to be relative to the real drive 0.
	4814	+ FCB $87
	4815	+ FCC 'MESSAG' ; 'MESSAGE'
	4816	+ FCB $C5
	4817	+ FDB DLINE-8
	4818	+MESS FDB DOCOL,WARN,AT,ZBRAN
	4819	+ FDB MESS3-*-NATWID
	4820	+ FDB DDUP,ZBRAN
	4821	+ FDB MESS3-*-NATWID
	4822	+ FDB LIT8
	4823	+ FCB 4
	4824	+ FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
	4825	+ FDB MESS4-*-NATWID
	4826	+MESS3 FDB PDOTQ
	4827	+ FCB 6
	4828	+ FCC 'err # ' ; 'err # '
	4829	+ FDB DOT
	4830	+MESS4 FDB SEMIS
	4831	+*
	4832	+* ======>> 180 <<
	4833	+* ( n --- )
	4834	+* Begin interpretation of screen (block) n.
	4835	+* See also ARROW, SEMIS, and NULL.
	4836	+ FCB $84
	4837	+ FCC 'LOA' ; 'LOAD' : input:scr #
	4838	+ FCB $C4
	4839	+ FDB MESS-10
	4840	+LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
	4841	+ FDB BSCR,STAR,BLK,STORE
	4842	+ FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
	4843	+ FDB SEMIS
	4844	+*
	4845	+* ======>> 181 <<
	4846	+* ( --- ) P
	4847	+* Continue interpreting source code on the next screen.
	4848	+ FCB $C3
	4849	+ FCC '--' ; '-->'
	4850	+ FCB $BE
	4851	+ FDB LOAD-7
	4852	+ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
	4853	+ FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
	4854	+ FDB SEMIS
	4855	+ PAGE
	4856	+*
	4857	+*
	4858	+* ######>> screen 63 <<
	4859	+* The next 4 subroutines are machine dependent, and are
	4860	+* called by words 13 through 16 in the dictionary.
	4861	+*
	4862	+* ======>> 182 << code for EMIT
	4863	+* ( --- ) No parameter stack effect.
	4864	+* Interfaces directly with ROM. Expects output character in D (therefore, B).
	4865	+* Output using rom CHROUT: redirectable to a printer on Coco.
	4866	+* Outputs the character on stack (low byte of 1 bit word/cell).
	4867	+PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.)
	4868	+ TFR B,A ; Coco ROM wants it in A.
	4869	+ CLRB
	4870	+ TFR B,DP ; Give the ROM its direct page.
	4871	+ JSR [$A002] ; Output the character in A.
	4872	+ PULS Y,U,DP,PC
	4873	+* PEMIT STB N save B
	4874	+* STX N+1 save X
	4875	+* LDB ACIAC
	4876	+* BITB #2 check ready bit
	4877	+* BEQ PEMIT+4 if not ready for more data
	4878	+* STA ACIAD
	4879	+* LDX UP
	4880	+* STB IOSTAT-UORIG,X
	4881	+* LDB N recover B & X
	4882	+* LDX N+1
	4883	+* RTS only A register may change
	4884	+* PEMIT JMP $E1D1 for MIKBUG
	4885	+* PEMIT FCB $3F,$11,$39 for PROTO
	4886	+* PEMIT JMP $D286 for Smoke Signal DOS
	4887	+*
	4888	+* ======>> 183 << code for KEY
	4889	+* ( --- ) No parameter stack effect.
	4890	+* Returns character or break flag in D, since this interfaces with Coco ROM.
	4891	+* Wait for key from POLCAT on Coco.
	4892	+* Returns the character code for the key pressed.
	4893	+PKEY PSHS Y,U,DP ; Must save everything important for this one.
	4894	+ LDA #$CF ; a cursor of sorts
	4895	+ CLRB
	4896	+ TFR B,DP
	4897	+ SETDP 0
	4898	+ LDX <$88 ; location
	4899	+ LDB ,X ; save glyph
	4900	+ STA ,X
	4901	+PKEYLP JSR [$A000]
	4902	+* STA $41A ; DBG!
	4903	+ BEQ PKEYLP
	4904	+* STD $418 ; DBG!
	4905	+ STB ,X ; restore
	4906	+PKEYR CLRB ; for the break flag, shares code with PQTER
	4907	+ CMPA #3 ; break key
	4908	+ BNE PKEYGT
	4909	+ COMB ; for the break flag
	4910	+PKEYGT EXG A,B ; Leave it in D for return.
	4911	+ PULS Y,U,DP,PC ; Shares exit with PQTER
	4912	+ SETDP IUPDP
	4913	+* PKEY STB N
	4914	+* STX N+1
	4915	+* LDB ACIAC
	4916	+* ASRB ;
	4917	+* BCC PKEY+4 no incoming data yet
	4918	+* LDA ACIAD
	4919	+* ANDA #$7F strip parity bit
	4920	+* LDX UP
	4921	+* STB IOSTAT+1-UORIG,X
	4922	+* LDB N
	4923	+* LDX N+1
	4924	+* RTS
	4925	+* PKEY JMP $E1AC for MIKBUG
	4926	+* PKEY FCB $3F,$14,$39 for PROTO
	4927	+* PKEY JMP $D289 for Smoke Signal DOS
	4928	+*
	4929	+* ######>> screen 64 <<
	4930	+* ======>> 184 << code for ?TERMINAL
	4931	+* ( --- f ) Should change this to no stack effect.
	4932	+* check break key using POLCAT
	4933	+* Returns a flag to tell whether the break key was pressed or not.
	4934	+PQTER PSHS Y,U,DP
	4935	+ CLRB
	4936	+ TFR B,DP
	4937	+ JSR [$A000] ; Look but don't wait.
	4938	+ BRA PKEYR
	4939	+* PQTER LDA ACIAC Test for 'break' condition
	4940	+* ANDA #$11 mask framing error bit and
	4941	+* input buffer full
	4942	+* BEQ PQTER2
	4943	+* LDA ACIAD clear input buffer
	4944	+* LDA #01
	4945	+* PQTER2 RTS
	4946	+
	4947	+
	4948	+ PAGE
	4949	+*
	4950	+* ======>> 185 << code for CR
	4951	+* ( --- ) No stack effect.
	4952	+* Interfaces directly with ROM.
	4953	+* For Coco just output a CR.
	4954	+* Also subject to redirection in Coco BASIC ROM.
	4955	+PCR LDB #$0D
	4956	+ BRA PEMIT ; Just steal the code.
	4957	+* PCR LDA #$D carriage return
	4958	+* BSR PEMIT
	4959	+* LDA #$A line feed
	4960	+* BSR PEMIT
	4961	+* LDA #$7F rubout
	4962	+* LDX UP
	4963	+* LDB XDELAY+1-UORIG,X
	4964	+* PCR2 DECB ;
	4965	+* BMI PQTER2 return if minus
	4966	+* PSHS B ; save counter
	4967	+* BSR PEMIT print RUBOUTs to delay.....
	4968	+* PULS B ;
	4969	+* BRA PCR2 repeat
	4970	+
	4971	+
	4972	+ PAGE
	4973	+*
	4974	+* ######>> screen 66 <<
	4975	+* ======>> 187 <<
	4976	+* ( ??? )
	4977	+* Query the disk, I suppose.
	4978	+* Not sure what the model had in mind for this stub.
	4979	+ FCB $85
	4980	+ FCC '?DIS' ; '?DISC'
	4981	+ FCB $C3
	4982	+ FDB ARROW-6
	4983	+QDISC FDB *+NATWID
	4984	+ JMP NEXT
	4985	+*
	4986	+* ######>> screen 67 <<
	4987	+* ======>> 189 <<
	4988	+* ( ??? )
	4989	+* Write one block of data to disk.
	4990	+* Parameters unspecified in model. Stub in model.
	4991	+ FCB $8B
	4992	+ FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
	4993	+ FCB $C5
	4994	+ FDB QDISC-8
	4995	+BWRITE FDB *+NATWID
	4996	+ JMP NEXT
	4997	+*
	4998	+* ######>> screen 68 <<
	4999	+* ======>> 190 <<
	5000	+* ( ??? )
	5001	+* Read one block of data from disk.
	5002	+* Parameters unspecified in model. Stub in model.
	5003	+ FCB $8A
	5004	+ FCC 'BLOCK-REA' ; 'BLOCK-READ'
	5005	+ FCB $C4
	5006	+ FDB BWRITE-14
	5007	+BREAD FDB *+NATWID
	5008	+ JMP NEXT
	5009	+*
	5010	+*The next 3 words are written to create a substitute for disc
	5011	+* mass memory,located between MASSLO & MASSHI in ram --
	5012	+* ($3210 and $3fff in the 6800 model).
	5013	+* ======>> 190.1 <<
	5014	+ FCB $82
	5015	+ FCC 'L' ; 'LO'
	5016	+ FCB $CF
	5017	+ FDB BREAD-13
	5018	+LO FDB DOCON
	5019	+ FDB MEMEND a system dependent equate at front
	5020	+*
	5021	+* ======>> 190.2 <<
	5022	+ FCB $82
	5023	+ FCC 'H' ; 'HI'
	5024	+ FCB $C9
	5025	+ FDB LO-5
	5026	+HI FDB DOCON
	5027	+ FDB MEMTOP ( $3FFF or $7FFF in this version )
	5028	+*
	5029	+* ######>> screen 69 <<
	5030	+* ======>> 191 <<
	5031	+* ( buffer sector f --- )
	5032	+* Read or Write the specified (absolute -- ignores OFFSET) sector
	5033	+* from or to the specified buffer.
	5034	+* A zero flag specifies write,
	5035	+* non-zero specifies read.
	5036	+* Sector is an unsigned integer,
	5037	+* buffer is the buffer's address.
	5038	+* Will need to use the CoCo ROM disk routines.
	5039	+* For now, provides a virtual disk in RAM.
	5040	+ FCB $83
	5041	+ FCC 'R/' ; 'R/W'
	5042	+ FCB $D7
	5043	+ FDB HI-5
	5044	+RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
	5045	+ FDB RW2-*-NATWID
	5046	+ FDB PDOTQ
	5047	+ FCB 8
	5048	+ FCC ' Range ?' ; ' Range ?'
	5049	+ FDB QUIT
	5050	+RW2 FDB FROMR,ZBRAN
	5051	+ FDB RW3-*-NATWID
	5052	+ FDB SWAP
	5053	+RW3 FDB BBUF,CMOVE
	5054	+ FDB SEMIS
	5055	+*
	5056	+* From BIF-6809:
	5057	+* RW PSHS Y,U,DP
	5058	+* LDY $C006 control table
	5059	+* LDX #DROFFS+7 ; This is BIF's table of drive sizes.
	5060	+* LDD 2,U
	5061	+* RWD SUBD ,X++ sectors
	5062	+* BHS RWD
	5063	+* BVC RWR table end?
	5064	+* LDD #6
	5065	+* PSHU D
	5066	+* JMP ERROR
	5067	+* RWR ADDD ,--X back one
	5068	+* PSHS X
	5069	+* PSHU D
	5070	+* LDD #18 sectors/track
	5071	+* PSHU D
	5072	+* DOCOL
	5073	+* FDB SLAMOD
	5074	+* FDB XMACH
	5075	+* PULU D
	5076	+* STB 2,Y track
	5077	+* PULU D
	5078	+* INCB
	5079	+* STB 3,Y sector
	5080	+* PULS D table entry
	5081	+* SUBD #DROFFS+7
	5082	+* ASRB drive #
	5083	+* STB 1,Y
	5084	+* LDD 4,U buffer
	5085	+* STD 4,Y
	5086	+* LDB #2 coco READ
	5087	+* LDX ,U 0?
	5088	+* BNE *+3
	5089	+* INCB coco WRITE
	5090	+* STB ,Y op code
	5091	+* CLRA
	5092	+* TFR A,DP
	5093	+* JSR [$C004] ROM handles timeout
	5094	+* PULS Y,U,DP if IRQ enabled
	5095	+* LEAU 6,U
	5096	+* LDX $C006
	5097	+* LDB 6,X coco status
	5098	+* BEQ RWE
	5099	+* LDX <UP
	5100	+* LDD #0 no disc
	5101	+* STD UWARN,X
	5102	+* LDD #8
	5103	+* PSHU D
	5104	+* JMP ERROR
	5105	+* RWE NEXT
	5106	+*
	5107	+* ######>> screen 72 <<
	5108	+* ======>> 192 <<
	5109	+* ( --- ) compiling P
	5110	+* ( --- adr ) interpreting
	5111	+* { ' name } input
	5112	+* Parse a symbol name from input and search the dictionary for it, per -FIND;
	5113	+* compile the address as a literal if compiling,
	5114	+* otherwise just push it.
	5115	+ FCB $C1 immediate
	5116	+ FCB $A7 ' ( tick )
	5117	+ FDB RW-6
	5118	+TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
	5119	+ FDB SEMIS
	5120	+*
	5121	+* ======>> 193 <<
	5122	+* ( --- ) { FORGET name } input
	5123	+* Parse out name of definition to FORGET to, -DFIND it,
	5124	+* then lop it and everything that follows out of the dictionary.
	5125	+* In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
	5126	+ FCB $86
	5127	+ FCC 'FORGE' ; 'FORGET'
	5128	+ FCB $D4
	5129	+ FDB TICK-4
	5130	+FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
	5131	+ FCB $18
	5132	+ FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT8
	5133	+ FCB $15
	5134	+ FDB QERR,DUP,ZERO,PORIG,GREAT,LIT8
	5135	+ FCB $15
	5136	+ FDB QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
	5137	+ FDB SEMIS
	5138	+*
	5139	+* ######>> screen 73 <<
	5140	+* ======>> 194 <<
	5141	+* ( adr --- ) C
	5142	+* Calculate a back reference from HERE and compile it.
	5143	+ FCB $84
	5144	+ FCC 'BAC' ; 'BACK'
	5145	+ FCB $CB
	5146	+ FDB FORGET-9
	5147	+* BACK FDB DOCOL,HERE,SUB,COMMA
	5148	+BACK FDB DOCOL,HERE,NATP,SUB,COMMA
	5149	+ FDB SEMIS
	5150	+*
	5151	+* ======>> 195 <<
	5152	+* ( --- ) runtime
	5153	+* typical use: BEGIN code-loop test UNTIL
	5154	+* typical use: BEGIN code-loop AGAIN
	5155	+* typical use: BEGIN code-loop test WHILE code-true REPEAT
	5156	+* ( --- adr n ) compile time P,C
	5157	+* Push HERE for BACK reference for general (non-counting) loops,
	5158	+* with BEGIN construct flag.
	5159	+* A better flag: $4245 (ASCII for 'BE').
	5160	+ FCB $C5
	5161	+ FCC 'BEGI' ; 'BEGIN'
	5162	+ FCB $CE
	5163	+ FDB BACK-7
	5164	+BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
	5165	+ FDB SEMIS
	5166	+*
	5167	+* ======>> 196 <<
	5168	+* ( --- ) runtime
	5169	+* typical use: test IF code-true ELSE code-false ENDIF
	5170	+* ENDIF is just a sort of intersection piece,
	5171	+* marking where execution resumes after both branches.
	5172	+* ( adr n --- ) compile time
	5173	+* Check the mark and resolve the IF.
	5174	+* A better flag: $4846 (ASCII for 'IF').
	5175	+ FCB $C5
	5176	+ FCC 'ENDI' ; 'ENDIF'
	5177	+ FCB $C6
	5178	+ FDB BEGIN-8
	5179	+ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
	5180	+ FDB OVER,NATP,SUB,SWAP,STORE
	5181	+ FDB SEMIS
	5182	+*
	5183	+* ======>> 197 <<
	5184	+* ( --- ) runtime
	5185	+* typical use: test IF code-true ELSE code-false ENDIF
	5186	+* ( adr n --- )
	5187	+* Alias for ENDIF .
	5188	+ FCB $C4
	5189	+ FCC 'THE' ; 'THEN'
	5190	+ FCB $CE
	5191	+ FDB ENDIF-8
	5192	+THEN FDB DOCOL,ENDIF
	5193	+ FDB SEMIS
	5194	+*
	5195	+* ======>> 198 <<
	5196	+* ( limit index --- ) runtime
	5197	+* typical use: DO code-loop LOOP
	5198	+* typical use: DO code-loop increment +LOOP
	5199	+* Counted loop, index is initial value of index.
	5200	+* Will loop until index equals (positive going)
	5201	+* or passes (negative going) limit.
	5202	+* ( --- adr n ) compile time P,C
	5203	+* Compile (DO), push HERE for BACK reference,
	5204	+* and push DO control construct flag.
	5205	+* A better flag: $444F (ASCII for 'DO').
	5206	+ FCB $C2
	5207	+ FCC 'D' ; 'DO'
	5208	+ FCB $CF
	5209	+ FDB THEN-7
	5210	+DO FDB DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
	5211	+ FDB SEMIS
	5212	+*
	5213	+* ======>> 199 <<
	5214	+* ( --- ) runtime
	5215	+* typical use: DO code-loop LOOP
	5216	+* Increments the index by one and branches back to beginning of loop.
	5217	+* Will loop until index equals limit.
	5218	+* ( adr n --- ) compile time P,C
	5219	+* Check the mark and compile (LOOP), fill in BACK reference.
	5220	+* A better flag: $444F (ASCII for 'DO').
	5221	+ FCB $C4
	5222	+ FCC 'LOO' ; 'LOOP'
	5223	+ FCB $D0
	5224	+ FDB DO-5
	5225	+LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
	5226	+ FDB SEMIS
	5227	+*
	5228	+* ======>> 200 <<
	5229	+* ( n --- ) runtime
	5230	+* typical use: DO code-loop increment +LOOP
	5231	+* Increments the index by n and branches back to beginning of loop.
	5232	+* Will loop until index equals (positive going)
	5233	+* or passes (negative going) limit.
	5234	+* ( adr n --- ) compile time P,C
	5235	+* Check the mark and compile (+LOOP), fill in BACK reference.
	5236	+* A better flag: $444F (ASCII for 'DO').
	5237	+ FCB $C5
	5238	+ FCC '+LOO' ; '+LOOP'
	5239	+ FCB $D0
	5240	+ FDB LOOP-7
	5241	+PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
	5242	+ FDB SEMIS
	5243	+*
	5244	+* ======>> 201 <<
	5245	+* ( n --- ) runtime
	5246	+* typical use: BEGIN code-loop test UNTIL
	5247	+* Will loop until UNTIL tests true.
	5248	+* ( adr n --- ) compile time P,C
	5249	+* Check the mark and compile (0BRANCH), fill in BACK reference.
	5250	+* A better flag: $4245 (ASCII for 'BE').
	5251	+ FCB $C5
	5252	+ FCC 'UNTI' ; 'UNTIL' : ( same as END )
	5253	+ FCB $CC
	5254	+ FDB PLOOP-8
	5255	+UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
	5256	+ FDB SEMIS
	5257	+*
	5258	+* ######>> screen 74 <<
	5259	+* ======>> 202 <<
	5260	+* ( n --- ) runtime
	5261	+* typical use: BEGIN code-loop test END
	5262	+* ( adr n --- )
	5263	+* Alias for UNTIL .
	5264	+ FCB $C3
	5265	+ FCC 'EN' ; 'END'
	5266	+ FCB $C4
	5267	+ FDB UNTIL-8
	5268	+END FDB DOCOL,UNTIL
	5269	+ FDB SEMIS
	5270	+*
	5271	+* ======>> 203 <<
	5272	+* ( --- ) runtime
	5273	+* typical use: BEGIN code-loop AGAIN
	5274	+* Will loop forever
	5275	+* (or until something uses R> DROP to force the current definition to die,
	5276	+* or perhaps ABORT or ERROR or some such other drastic means stops things).
	5277	+* ( adr n --- ) compile time P,C
	5278	+* Check the mark and compile (0BRANCH), fill in BACK reference.
	5279	+* A better flag: $4245 (ASCII for 'BE').
	5280	+ FCB $C5
	5281	+ FCC 'AGAI' ; 'AGAIN'
	5282	+ FCB $CE
	5283	+ FDB END-6
	5284	+AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
	5285	+ FDB SEMIS
	5286	+*
	5287	+* ======>> 204 <<
	5288	+* ( --- ) runtime
	5289	+* typical use: BEGIN code-loop test WHILE code-true REPEAT
	5290	+* Will loop until WHILE tests false, skipping code-true on end.
	5291	+* REPEAT marks where execution resumes after the WHILE find a false flag.
	5292	+* ( aadr1 n1 adr2 n2 --- ) compile time P,C
	5293	+* Check the marks for WHILE and BEGIN,
	5294	+* compile BRANCH and BACK fill adr1 reference,
	5295	+* FILL-IN 0BRANCH reference at adr2.
	5296	+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
	5297	+ FCB $C6
	5298	+ FCC 'REPEA' ; 'REPEAT'
	5299	+ FCB $D4
	5300	+ FDB AGAIN-8
	5301	+REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
	5302	+ FDB TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
	5303	+ FDB SEMIS
	5304	+*
	5305	+* ======>> 205 <<
	5306	+* ( n --- ) runtime
	5307	+* typical use: test IF code-true ELSE code-false ENDIF
	5308	+* Will pass execution to the true part on a true flag
	5309	+* and to the false part on a false flag.
	5310	+* ( --- adr n ) compile time P,C
	5311	+* Compile a 0BRANCH and dummy offset
	5312	+* and push IF reference to fill in and
	5313	+* IF control construct flag.
	5314	+* A better flag: $4946 (ASCII for 'IF').
	5315	+ FCB $C2
	5316	+ FCC 'I' ; 'IF'
	5317	+ FCB $C6
	5318	+ FDB REPEAT-9
	5319	+IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
	5320	+ FDB SEMIS
	5321	+*
	5322	+* ======>> 206 <<
	5323	+* ( --- ) runtime
	5324	+* typical use: test IF code-true ELSE code-false ENDIF
	5325	+* ELSE is just a sort of intersection piece,
	5326	+* marking where execution resumes on a false branch.
	5327	+* ( adr1 n --- adr2 n ) compile time P,C
	5328	+* Check the marks,
	5329	+* compile BRANCH with dummy offset,
	5330	+* resolve IF reference,
	5331	+* and leave reference to BRANCH for ELSE.
	5332	+* A better flag: $4946 (ASCII for 'IF').
	5333	+ FCB $C4
	5334	+ FCC 'ELS' ; 'ELSE'
	5335	+ FCB $C5
	5336	+ FDB IF-5
	5337	+ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
	5338	+ FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
	5339	+ FDB SEMIS
	5340	+*
	5341	+* ======>> 207 <<
	5342	+* ( n --- ) runtime
	5343	+* typical use: BEGIN code-loop test WHILE code-true REPEAT
	5344	+* Will loop until WHILE tests false, skipping code-true on end.
	5345	+* ( --- adr n ) compile time P,C
	5346	+* Compile 0BRANCH with dummy offset (using IF),
	5347	+* push WHILE reference.
	5348	+* BEGIN flag will sit underneath this.
	5349	+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
	5350	+ FCB $C5
	5351	+ FCC 'WHIL' ; 'WHILE'
	5352	+ FCB $C5
	5353	+ FDB ELSE-7
	5354	+WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
	5355	+ FDB SEMIS
	5356	+*
	5357	+* ######>> screen 75 <<
	5358	+* ======>> 208 <<
	5359	+* ( count --- )
	5360	+* EMIT count spaces, for non-zero, non-negative counts.
	5361	+ FCB $86
	5362	+ FCC 'SPACE' ; 'SPACES'
	5363	+ FCB $D3
	5364	+ FDB WHILE-8
	5365	+SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
	5366	+ FDB SPACE3-*-NATWID
	5367	+ FDB ZERO,XDO
	5368	+SPACE2 FDB SPACE,XLOOP
	5369	+ FDB SPACE2-*-NATWID
	5370	+SPACE3 FDB SEMIS
	5371	+*
	5372	+* ======>> 209 <<
	5373	+* ( --- )
	5374	+* Initialize HLD for converting a double integer.
	5375	+* Stores the PAD address in HLD.
	5376	+ FCB $82
	5377	+ FCC '<' ; '<#'
	5378	+ FCB $A3
	5379	+ FDB SPACES-9
	5380	+BDIGS FDB DOCOL,PAD,HLD,STORE
	5381	+ FDB SEMIS
	5382	+*
	5383	+* ======>> 210 <<
	5384	+* ( d --- string length )
	5385	+* Terminate numeric conversion,
	5386	+* drop the number being converted,
	5387	+* leave the address of the conversion string and the length, ready for TYPE.
	5388	+ FCB $82
	5389	+ FCC '#' ; '#>'
	5390	+ FCB $BE
	5391	+ FDB BDIGS-5
	5392	+EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
	5393	+ FDB SEMIS
	5394	+*
	5395	+* ======>> 211 <<
	5396	+* ( n d --- d )
	5397	+* Put sign of n (as a flag) at the head of the conversion string.
	5398	+* Drop the sign flag.
	5399	+ FCB $84
	5400	+ FCC 'SIG' ; 'SIGN'
	5401	+ FCB $CE
	5402	+ FDB EDIGS-5
	5403	+SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
	5404	+ FDB SIGN2-*-NATWID
	5405	+ FDB LIT8
	5406	+ FCC "-"
	5407	+ FDB HOLD
	5408	+SIGN2 FDB SEMIS
	5409	+*
	5410	+* ======>> 212 <<
	5411	+* ( d --- d/base )
	5412	+* Generate next most significant digit in the conversion BASE,
	5413	+* putting the digit at the head of the conversion string.
	5414	+ FCB $81 #
	5415	+ FCB $A3
	5416	+ FDB SIGN-7
	5417	+DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
	5418	+ FCB 9
	5419	+ FDB OVER,LESS,ZBRAN
	5420	+ FDB DIG2-*-NATWID
	5421	+ FDB LIT8
	5422	+ FCB 7
	5423	+ FDB PLUS
	5424	+DIG2 FDB LIT8
	5425	+ FCC "0" ascii zero
	5426	+ FDB PLUS,HOLD
	5427	+ FDB SEMIS
	5428	+*
	5429	+* ======>> 213 <<
	5430	+* ( d --- dzero )
	5431	+* Convert d to a numeric string using # until the result is zero.
	5432	+* Leave the double result on the stack for #> to drop.
	5433	+ FCB $82
	5434	+ FCC '#' ; '#S'
	5435	+ FCB $D3
	5436	+ FDB DIG-4
	5437	+DIGS FDB DOCOL
	5438	+DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
	5439	+ FDB DIGS2-*-NATWID
	5440	+ FDB SEMIS
	5441	+*
	5442	+* ######>> screen 76 <<
	5443	+* ======>> 214 <<
	5444	+* ( n width --- )
	5445	+* Print n on the output device in the current conversion base,
	5446	+* with sign,
	5447	+* right aligned in a field at least width wide.
	5448	+ FCB $82
	5449	+ FCC '.' ; '.R'
	5450	+ FCB $D2
	5451	+ FDB DIGS-5
	5452	+DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
	5453	+ FDB SEMIS
	5454	+*
	5455	+* ======>> 215 <<
	5456	+* ( d width --- )
	5457	+* Print d on the output device in the current conversion base,
	5458	+* with sign,
	5459	+* right aligned in a field at least width wide.
	5460	+ FCB $83
	5461	+ FCC 'D.' ; 'D.R'
	5462	+ FCB $D2
	5463	+ FDB DOTR-5
	5464	+DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
	5465	+ FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
	5466	+ FDB SEMIS
	5467	+*
	5468	+* ======>> 216 <<
	5469	+* D. ( d --- )
	5470	+* Print d on the output device in the current conversion base,
	5471	+* with sign,
	5472	+* in free format with trailing space.
	5473	+ FCB $82
	5474	+ FCC 'D' ; 'D.'
	5475	+ FCB $AE
	5476	+ FDB DDOTR-6
	5477	+DDOT FDB DOCOL,ZERO,DDOTR,SPACE
	5478	+ FDB SEMIS
	5479	+*
	5480	+* ======>> 217 <<
	5481	+* ( n --- )
	5482	+* Print n on the output device in the current conversion base,
	5483	+* with sign,
	5484	+* in free format with trailing space.
	5485	+ FCB $81 .
	5486	+ FCB $AE
	5487	+ FDB DDOT-5
	5488	+DOT FDB DOCOL,STOD,DDOT
	5489	+ FDB SEMIS
	5490	+*
	5491	+* ======>> 218 <<
	5492	+* ( adr --- )
	5493	+* Print signed word at adr, per DOT.
	5494	+ FCB $81 ?
	5495	+ FCB $BF
	5496	+ FDB DOT-4
	5497	+QUEST FDB DOCOL,AT,DOT
	5498	+ FDB SEMIS
	5499	+*
	5500	+* ######>> screen 77 <<
	5501	+* ======>> 219 <<
	5502	+* ( n --- )
	5503	+* Print out screen n as a field of ASCII,
	5504	+* with line numbers in decimal.
	5505	+* Needs a console more than 70 characters wide.
	5506	+ FCB $84
	5507	+ FCC 'LIS' ; 'LIST'
	5508	+ FCB $D4
	5509	+ FDB QUEST-4
	5510	+LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
	5511	+ FCB 6
	5512	+ FCC "SCR # "
	5513	+ FDB DOT,LIT8
	5514	+ FCB $10
	5515	+ FDB ZERO,XDO
	5516	+LIST2 FDB CR,I,THREE
	5517	+ FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
	5518	+ FDB LIST2-*-NATWID
	5519	+ FDB CR
	5520	+ FDB SEMIS
	5521	+*
	5522	+* ======>> 220 <<
	5523	+* ( start end --- )
	5524	+* Print comment lines (line 0, and line 1 if C/L < 41) of screens
	5525	+* from start to end.
	5526	+* Needs a console more than 70 characters wide.
	5527	+ FCB $85
	5528	+ FCC 'INDE' ; 'INDEX'
	5529	+ FCB $D8
	5530	+ FDB LIST-7
	5531	+INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
	5532	+INDEX2 FDB CR,I,THREE
	5533	+ FDB DOTR,SPACE,ZERO,I,DLINE
	5534	+ FDB QTERM,ZBRAN
	5535	+ FDB INDEX3-*-NATWID
	5536	+ FDB LEAVE
	5537	+INDEX3 FDB XLOOP
	5538	+ FDB INDEX2-*-NATWID
	5539	+ FDB SEMIS
	5540	+*
	5541	+* ======>> 221 <<
	5542	+* ( n --- )
	5543	+* List a printer page full of screens.
	5544	+* Line and screen number are in current base.
	5545	+* Needs a console more than 70 characters wide.
	5546	+ FCB $85
	5547	+ FCC 'TRIA' ; 'TRIAD'
	5548	+ FCB $C4
	5549	+ FDB INDEX-8
	5550	+TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
	5551	+ FDB THREE,OVER,PLUS,SWAP,XDO
	5552	+TRIAD2 FDB CR,I
	5553	+ FDB LIST,QTERM,ZBRAN
	5554	+ FDB TRIAD3-*-NATWID
	5555	+ FDB LEAVE
	5556	+TRIAD3 FDB XLOOP
	5557	+ FDB TRIAD2-*-NATWID
	5558	+ FDB CR,LIT8
	5559	+ FCB $0F
	5560	+ FDB MESS,CR
	5561	+ FDB SEMIS
	5562	+*
	5563	+* ######>> screen 78 <<
	5564	+* ======>> 222 <<
	5565	+* ( --- )
	5566	+* Alphabetically list the definitions in the current vocabulary.
	5567	+* Expects to output to printer, not TRS80 Color Computer screen.
	5568	+ FCB $85
	5569	+ FCC 'VLIS' ; 'VLIST'
	5570	+ FCB $D4
	5571	+ FDB TRIAD-8
	5572	+VLIST FDB DOCOL,LIT8
	5573	+ FCB $80
	5574	+ FDB OUT,STORE,CONTXT,AT,AT
	5575	+VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
	5576	+ FCB 32
	5577	+ FDB SUB,GREAT,ZBRAN
	5578	+ FDB VLIST2-*-NATWID
	5579	+ FDB CR,ZERO,OUT,STORE
	5580	+VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
	5581	+ FDB DUP,ZEQU,QTERM,OR,ZBRAN
	5582	+ FDB VLIST1-*-NATWID
	5583	+ FDB DROP
	5584	+ FDB SEMIS
	5585	+*
	5586	+* Need some utility stuff that isn't in the fig FORTH:
	5587	+* ( c --- )
	5588	+* Emit dot if c is less than blank, else emit c
	5589	+ FCB $85
	5590	+ FCC 'BEMI' ; 'BEMIT'
	5591	+ FCB $D4 ; 'T'
	5592	+ FDB VLIST-8
	5593	+BEMIT FDB DOCOL
	5594	+ FDB DUP,BL,LESS,ZBRAN
	5595	+ FDB BEMITO-*-NATWID
	5596	+ FDB DROP,LIT8
	5597	+ FCB $2e ; '.'
	5598	+BEMITO FDB EMIT
	5599	+ FDB SEMIS
	5600	+*
	5601	+* ( n width --- )
	5602	+* Output n in hexadecimal field width.
	5603	+ FCB $83
	5604	+ FCC 'X.' ; 'X.R'
	5605	+ FCB $D2 ; 'R'
	5606	+ FDB BEMIT-8
	5607	+XDOTR FDB DOCOL
	5608	+ FDB BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
	5609	+ FDB SEMIS
	5610	+*
	5611	+* ( adr --- )
	5612	+* Dump a line of 4 bytes in memory, in hex and as characters.
	5613	+ FCB $85
	5614	+ FCC 'BLIN' ; 'BLINE'
	5615	+ FCB $C5 ; 'E'
	5616	+ FDB XDOTR-6
	5617	+BLINE FDB DOCOL
	5618	+ FDB DUP,LIT8
	5619	+ FCB 4
	5620	+ FDB PLUS,OVER,XDO
	5621	+BLINEX FDB I,CAT,THREE,XDOTR,XLOOP
	5622	+ FDB BLINEX-*-NATWID
	5623	+ FDB SPACE,SPACE
	5624	+ FDB DUP,LIT8
	5625	+ FCB 4
	5626	+ FDB PLUS,SWAP,XDO
	5627	+BLINEC FDB I,CAT,BEMIT,XLOOP
	5628	+ FDB BLINEC-*-NATWID
	5629	+ FDB SEMIS
	5630	+*
	5631	+* ( start end --- )
	5632	+* Dump 4 byte lines from start to end.
	5633	+ FCB $85
	5634	+ FCC 'BDUM' ; 'BDUMP'
	5635	+ FCB $D0 ; '5'
	5636	+ FDB BLINE-8
	5637	+BDUMP FDB DOCOL
	5638	+ FDB CR,XDO
	5639	+BDUMPL FDB I,LIT8
	5640	+ FCB 4
	5641	+ FDB XDOTR,LIT8
	5642	+ FCB $3A
	5643	+ FDB EMIT,SPACE
	5644	+ FDB I,BLINE,CR,LIT8
	5645	+ FCB 4
	5646	+ FDB XPLOOP
	5647	+ FDB BDUMPL-*-NATWID
	5648	+ FDB SEMIS
	5649	+*
	5650	+* ======>> XX <<
	5651	+* ( --- )
	5652	+* Mostly for place holding (fig Forth).
	5653	+ FCB $84
	5654	+ FCC 'NOO' ; 'NOOP'
	5655	+ FCB $D0
	5656	+ FDB BDUMP-8
	5657	+NOOP FDB *+NATWID
	5658	+ RTS
	5659	+* Without the RTS, would misalign the stack.
	5660	+* NOOP NEXT a useful no-op
	5661	+ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
	5662	+
	5663	+ PAGE
	5664	+* These things, up through the lable 'REND', are overwritten
	5665	+* at time of cold load and should have the same contents
	5666	+* as shown here:
	5667	+*
	5668	+* This can be moved whereever the bottom of the
	5669	+* user's dictionary is going to be put.
	5670	+*
	5671	+RBEG EQU *
	5672	+ FCB $C5 immediate
	5673	+ FCC 'FORT' ; 'FORTH'
	5674	+ FCB $C8
	5675	+ FDB NOOP-7
	5676	+FORTH FDB DODOES,DOVOC,$81A0,TASK-7
	5677	+ FDB 0
	5678	+*
	5679	+ FCC "Copyright 1979 Forth Interest Group, David Lion,"
	5680	+ FCB $0D
	5681	+ FCC "Parts Copyright 2019 Joel Matthew Rees"
	5682	+ FCB $0D
	5683	+*
	5684	+ FCB $84
	5685	+ FCC 'TAS' ; 'TASK'
	5686	+ FCB $CB
	5687	+ FDB FORTH-8
	5688	+TASK FDB DOCOL,SEMIS
	5689	+*
	5690	+REND EQU * ( first empty location in dictionary )
	5691	+RSIZE EQU *-RBEG ; So we can look at it.
	5692	+ PAGE
	5693	+
	5694	+ ORG RAMDSK
	5695	+* "0 1 2 3 4 5 6 " ;
	5696	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5697	+ FCC " 0) Index page " ; 0
	5698	+ FCC " 1) empty line on line 1 of screen 0 block 0 " ; 1
	5699	+ FCC " 2) Title and copyright " ; 2
	5700	+ FCC " 3) empty line on line 3 of screen 0 block 0 " ; 3
	5701	+ FCC " 4) Error messages 1st screen " ; 4
	5702	+ FCC " 5) Error messages 2nd screen " ; 5
	5703	+ FCC " 6) empty line 3 screen 0 block 1 " ; 6
	5704	+ FCC " 7) empty line 4 " ; 7
	5705	+ FCC " 8) and line 1 of block 2 " ; 8
	5706	+ FCC " 9) line 2 of block 2 screen 0 is pretty much empty too " ; 9
	5707	+ FCC " 10) listen to this. Line three of block two is too " ; 10
	5708	+ FCC " 11) and so is line 4 4 4 4 4 4 4 4 4 4 b2s0 " ; 11
	5709	+ FCC " 12) screen zero block three first line " ; 12
	5710	+ FCC " 13) second line fourth block (block three) screen 0 " ; 13
	5711	+ FCC " 14) block three screen zero line 3 3 3 3 3 3 3 3 3 " ; 14
	5712	+ FCC " 15) fourth line block three screen 0 0 0 0 0 0 0 0 0 0 " ; 15
	5713	+* "0 1 2 3 4 5 6 " ;
	5714	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5715	+ FCC " test 10 b0s1 aaaa " ; 0
	5716	+ FCC " test 11 b0s1 ee ee ee ee " ; 1
	5717	+ FCC " test 12 b0s1 oo oo oo oo oo " ; 2
	5718	+ FCC " test 13 b0s1 eh ehe he eh eh " ; 3
	5719	+ FCC " ( block 1 ) b1s1 oh ohoo oh oh oh " ; 4
	5720	+ FCC " 15 test b1s1 " ; 5
	5721	+ FCC " 16 test b1s1 " ; 6
	5722	+ FCC " 17 test b1s1 " ; 7
	5723	+ FCC " 18 test b2s1 " ; 8
	5724	+ FCC " 19 test b2s1 " ; 9
	5725	+ FCC " 1A test b2s1 " ; 10
	5726	+ FCC " 1B test b2ws1 " ; 11
	5727	+ FCC " 1C test b3s1 " ; 12
	5728	+ FCC " 1D test b3s1 " ; 13
	5729	+ FCC " 1e this completes our second screen b3s1 " ; 14
	5730	+ FCC " 1F test b3s1 " ; 15
	5731	+* "0 1 2 3 4 5 6 " ;
	5732	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5733	+ FCC " " ; 0
	5734	+ FCC " fig Forth High Level Model Code " ; 1
	5735	+ FCC " " ; 2
	5736	+ FCC " Copyright 2018 Joel Matthew Rees " ; 3
	5737	+ FCC " ( block 2 ) " ; 4
	5738	+ FCC " " ; 5
	5739	+ FCC " " ; 6
	5740	+ FCC " " ; 7
	5741	+ FCC " " ; 8
	5742	+ FCC " " ; 9
	5743	+ FCC " " ; 10
	5744	+ FCC " " ; 11
	5745	+ FCC " " ; 12
	5746	+ FCC " " ; 13
	5747	+ FCC " " ; 14
	5748	+ FCC " " ; 15
	5749	+* "0 1 2 3 4 5 6 " ;
	5750	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5751	+ FCC " " ; 0
	5752	+ FCC " " ; 1
	5753	+ FCC " " ; 2
	5754	+ FCC " " ; 3
	5755	+ FCC " ( block 3 ) " ; 4
	5756	+ FCC " " ; 5
	5757	+ FCC " " ; 6
	5758	+ FCC " " ; 7
	5759	+ FCC " " ; 8
	5760	+ FCC " " ; 9
	5761	+ FCC " " ; 10
	5762	+ FCC " " ; 11
	5763	+ FCC " " ; 12
	5764	+ FCC " " ; 13
	5765	+ FCC " " ; 14
	5766	+ FCC " " ; 15
	5767	+* "0 1 2 3 4 5 6 " ;
	5768	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5769	+ FCC " " ; 0
	5770	+ FCC " " ; 1
	5771	+ FCC " " ; 2
	5772	+ FCC " " ; 3
	5773	+ FCC " ( block 4 ) " ; 4
	5774	+ FCC " " ; 5
	5775	+ FCC " " ; 6
	5776	+ FCC " " ; 7
	5777	+ FCC " " ; 8
	5778	+ FCC " " ; 9
	5779	+ FCC " " ; 10
	5780	+ FCC " " ; 11
	5781	+ FCC " " ; 12
	5782	+ FCC " " ; 13
	5783	+ FCC " " ; 14
	5784	+ FCC " " ; 15
	5785	+* "0 1 2 3 4 5 6 " ;
	5786	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5787	+ FCC " ( ERROR MESSAGES ) " ; 0
	5788	+ FCC " DATA STACK UNDERFLOW " ; 1
	5789	+ FCC " DICTIONARY FULL " ; 2
	5790	+ FCC " ADDRESS RESOLUTION ERROR " ; 3
	5791	+ FCC " HIDES DEFINITION IN " ; 4
	5792	+ FCC " " ; 5
	5793	+ FCC " " ; 6
	5794	+ FCC " " ; 7
	5795	+ FCC " " ; 8
	5796	+ FCC " " ; 9
	5797	+ FCC " " ; 10
	5798	+ FCC " " ; 11
	5799	+ FCC " " ; 12
	5800	+ FCC " " ; 13
	5801	+ FCC " " ; 14
	5802	+ FCC " " ; 15
	5803	+* "0 1 2 3 4 5 6 " ;
	5804	+* "0123456789012345678901234567890123456789012345678901234567890123" ;
	5805	+ FCC " more test data 2 3 4 5 6 " ; 0
	5806	+ FCC "0123456789012345678901234567890123456789012345678901234567890123" ; 1
	5807	+ FCC "Test data for the RAM disc emulator buffers. " ; 2
	5808	+ FCC " " ; 3
	5809	+ FCC " ( block 6 ) " ; 4
	5810	+ FCC " " ; 5
	5811	+ FCC " " ; 6
	5812	+ FCC " " ; 7
	5813	+ FCC " " ; 8
	5814	+ FCC " " ; 9
	5815	+ FCC " " ; 10
	5816	+ FCC " " ; 11
	5817	+ FCC " " ; 12
	5818	+ FCC " " ; 13
	5819	+ FCC " " ; 14
	5820	+ FCC " end" ; 15
	5821	+RAMDND EQU *
	5822	+
	5823	+
	5824	+ PAGE
	5825	+ OPT L
	5826	+ END

--- a/fig-forth-auto6809.asm

+++ /dev/null

		@@ -1,3162 +0,0 @@
1		- OPT PRT
2		-
3		-* fig-FORTH FOR 6800
4		-* ASSEMBLY SOURCE LISTING
5		-
6		-* RELEASE 1
7		-* MAY 1979
8		-* WITH COMPILER SECURITY
9		-* AND VARIABLE LENGTH NAMES
10		-
11		-* This public domain publication is provided
12		-* through the courtesy of:
13		-* FORTH
14		-* INTEREST
15		-* GROUP
16		-* fig
17		-
18		-* P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
19		-* Further distribution must include this notice.
20		- PAGE
21		- NAM Copyright:FORTH Interest Group
22		- OPT NOG,PAG
23		-* filename FTH7.21
24		-* === FORTH-6800 06-06-79 21:OO
25		-
26		-
27		-* This listing is in the PUBLIC DOMAIN and
28		-* may be freely copied or published with the
29		-* restriction that a credit line is printed
30		-* with the material, crediting the
31		-* authors and the FORTH INTEREST GROUP.
32		-
33		-* === by Dave Lion,
34		-* === with help from
35		-* === Bob Smith,
36		-* === LaFarr Stuart,
37		-* === The Forth Interest Group
38		-* === PO Box 1105
39		-* === San Carlos, CA 94070
40		-* === and
41		-* === Unbounded Computing
42		-* === 1134-K Aster Ave.
43		-* === Sunnyvale, CA 94086
44		-*
45		-* This version was developed on an AMI EVK 300 PROTO
46		-* system using an ACIA for the I/O. All terminal 1/0
47		-* is done in three subroutines:
48		-* PEMIT ( word # 182 )
49		-* PKEY ( 183 )
50		-* PQTERM ( 184 )
51		-*
52		-* The FORTH words for disc related I/O follow the model
53		-* of the FORTH Interest Group, but have not been
54		-* tested using a real disc.
55		-*
56		-* Addresses in this implementation reflect the fact that,
57		-* on the development system, it was convenient to
58		-* write-protect memory at hex 1000, and leave the first
59		-* 4K bytes write-enabled. As a consequence, code from
60		-* location $1000 to lable ZZZZ could be put in ROM.
61		-* Minor deviations from the model were made in the
62		-* initialization and words ?STACK and FORGET
63		-* in order to do this.
64		-*
65		-
66		-
67		-*
68		-NBLK EQU 4 # of disc buffer blocks for virtual memory
69		-MEMEND EQU 132*NBLK+$3000 end of ram
70		-* each block is 132 bytes in size,
71		-* holding 128 characters
72		-*
73		-MEMTOP EQU $3FFF absolute end of all ram
74		-ACIAC EQU $FBCE the ACIA control address and
75		-ACIAD EQU ACIAC+1 data address for PROTO
76		- PAGE
77		-* MEMORY MAP for this 16K system:
78		-* ( positioned so that systems with 4k byte write-
79		-* protected segments can write protect FORTH )
80		-*
81		-* addr. contents pointer init by
82		-* ** *************************** *** ****
83		-* 3FFF HI
84		-* substitute for disc mass memory
85		-* 3210 LO,MEMEND
86		-* 320F
87		-* 4 buffer sectors of VIRTUAL MEMORY
88		-* 3000 FIRST
89		-* >>>>>> memory from here up must be RAM <<<<<<
90		-*
91		-* 27FF
92		-* 6k of romable "FORTH" <== IP ABORT
93		-* <== W
94		-* the VIRTUAL FORTH MACHINE
95		-*
96		-* 1004 <<< WARM START ENTRY >>>
97		-* 1000 <<< COLD START ENTRY >>>
98		-*
99		-* >>>>>> memory from here down must be RAM <<<<<<
100		-* FFE RETURN STACK base <== RP RINIT
101		-*
102		-* FB4
103		-* INPUT LINE BUFFER
104		-* holds up to 132 characters
105		-* and is scanned upward by IN
106		-* starting at TIB
107		-* F30 <== IN TIB
108		-* F2F DATA STACK <== SP SP0,SINIT
109		-* \| grows downward from F2F
110		-* v
111		-* - -
112		-* \|
113		-* I DICTIONARY grows upward
114		-*
115		-* 183 end of ram-dictionary. <== DP DPINIT
116		-* "TASK"
117		-*
118		-* 150 "FORTH" ( a word ) <=, <== CONTEXT
119		-* `==== CURRENT
120		-* 148 start of ram-dictionary.
121		-*
122		-* 100 user #l table of variables <= UP DPINIT
123		-* F0 registers & pointers for the virtual machine
124		-* scratch area used by various words
125		-* E0 lowest address used by FORTH
126		-*
127		-* 0000
128		- PAGE
129		-***
130		-*
131		-* CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
132		-*
133		-* IP points to the current instruction ( pre-increment mode )
134		-* RP points to second free byte (first free word) in return stack
135		-* SP (hardware SP) points to first free byte in data stack
136		-*
137		-* when A and B hold one 16 bit FORTH data word,
138		-* A contains the high byte, B, the low byte.
139		-***
140		-
141		-
142		-
143		-
144		- ORG $E0 variables
145		-
146		-
147		-N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
148		-* SP@,SWAP,DOES>,COLD
149		-
150		-
151		-* These locations are used by the TRACE routine :
152		-
153		-TRLIM RMB 1 the count for tracing without user intervention
154		-TRACEM RMB 1 non-zero = trace mode
155		-BRKPT RMB 2 the breakpoint address at which
156		-* the program will go into trace mode
157		-VECT RMB 2 vector to machine code
158		-* (only needed if the TRACE routine is resident)
159		-
160		-
161		-* Registers used by the FORTH virtual machine:
162		-* Starting at $OOFO:
163		-
164		-
165		-W RMB 2 the instruction register points to 6800 code
166		-IP RMB 2 the instruction pointer points to pointer to 6800 code
167		-RP RMB 2 the return stack pointer
168		-UP RMB 2 the pointer to base of current user's 'USER' table
169		-* ( altered during multi-tasking )
170		-*
171		- PAGE
172		-* This system is shown with one user, but additional users
173		-* may be added by allocating additional user tables:
174		-* UORIG2 RMB 64 data table for user #2
175		-*
176		-*
177		-* Some of this stuff gets initialized during
178		-* COLD start and WARM start:
179		-* [ names correspond to FORTH words of similar (no X) name ]
180		-*
181		- ORG $100
182		-UORIG RMB 6 3 reserved variables
183		-XSPZER RMB 2 initial top of data stack for this user
184		-XRZERO RMB 2 initial top of return stack
185		-XTIB RMB 2 start of terminal input buffer
186		-XWIDTH RMB 2 name field width
187		-XWARN RMB 2 warning message mode (0 = no disc)
188		-XFENCE RMB 2 fence for FORGET
189		-XDP RMB 2 dictionary pointer
190		-XVOCL RMB 2 vocabulary linking
191		-XBLK RMB 2 disc block being accessed
192		-XIN RMB 2 scan pointer into the block
193		-XOUT RMB 2 cursor position
194		-XSCR RMB 2 disc screen being accessed ( O=terminal )
195		-XOFSET RMB 2 disc sector offset for multi-disc
196		-XCONT RMB 2 last word in primary search vocabulary
197		-XCURR RMB 2 last word in extensible vocabulary
198		-XSTATE RMB 2 flag for 'interpret' or 'compile' modes
199		-XBASE RMB 2 number base for I/O numeric conversion
200		-XDPL RMB 2 decimal point place
201		-XFLD RMB 2
202		-XCSP RMB 2 current stack position, for compile checks
203		-XRNUM RMB 2
204		-XHLD RMB 2
205		-XDELAY RMB 2 carriage return delay count
206		-XCOLUM RMB 2 carriage width
207		-IOSTAT RMB 2 last acia status from write/read
208		- RMB 2 ( 4 spares! )
209		- RMB 2
210		- RMB 2
211		- RMB 2
212		-
213		-
214		-
215		-
216		-*
217		-*
218		-* end of user table, start of common system variables
219		-*
220		-*
221		-*
222		-XUSE RMB 2
223		-XPREV RMB 2
224		- RMB 4 ( spares )
225		-
226		- PAGE
227		-* These things, up through the lable 'REND', are overwritten
228		-* at time of cold load and should have the same contents
229		-* as shown here:
230		-*
231		- FCB $C5 immediate
232		- FCC 'FORT' ; 'FORTH'
233		- FCB $C8
234		- FDB NOOP-7
235		-FORTH FDB DODOES,DOVOC,$81A0,TASK-7
236		- FDB 0
237		-*
238		- FCC "(C) Forth Interest Group, 1979"
239		-
240		- FCB $84
241		- FCC 'TAS' ; 'TASK'
242		- FCB $CB
243		- FDB FORTH-8
244		-TASK FDB DOCOL,SEMIS
245		-*
246		-REND EQU * ( first empty location in dictionary )
247		-
248		- PAGE
249		-* The FORTH program ( address $1000 to $27FF ) is written
250		-* so that it can be in a ROM, or write-protected if desired
251		- ORG $1000
252		-
253		-* ######>> screen 3 <<
254		-*
255		-***************************
256		- C O L D E N T R Y
257		-***************************
258		-ORIG NOP
259		- JMP CENT
260		-***************************
261		- W A R M E N T R Y
262		-***************************
263		- NOP
264		- JMP WENT warm-start code, keeps current dictionary intact
265		-
266		-*
267		-***** startup parmeters ************************
268		-*
269		- FDB $6800,0000 cpu & revision
270		- FDB 0 topmost word in FORTH vocabulary
271		-BACKSP FDB $7F backspace character for editing
272		-UPINIT FDB UORIG initial user area
273		-SINIT FDB ORIG-$D0 initial top of data stack
274		-RINIT FDB ORIG-2 initial top of return stack
275		- FDB ORIG-$D0 terminal input buffer
276		- FDB 31 initial name field width
277		- FDB 0 initial warning mode (0 = no disc)
278		-FENCIN FDB REND initial fence
279		-DPINIT FDB REND cold start value for DP
280		-VOCINT FDB FORTH+8
281		-COLINT FDB 132 initial terminal carriage width
282		-DELINT FDB 4 initial carriage return delay
283		-****************************************************
284		-*
285		- PAGE
286		-*
287		-* ######>> screen 13 <<
288		-PULABX PULS A ; 24 cycles until 'NEXT'
289		- PULS B ;
290		-STABX STA 0,X 16 cycles until 'NEXT'
291		- STB 1,X
292		- BRA NEXT
293		-GETX LDA 0,X 18 cycles until 'NEXT'
294		- LDB 1,X
295		-PUSHBA PSHS B ; 8 cycles until 'NEXT'
296		- PSHS A ;
297		-
298		-
299		-
300		-*
301		-* "NEXT" takes 38 cycles if TRACE is removed,
302		-*
303		-* and 95 cycles if NOT tracing.
304		-*
305		-* = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
306		-* =
307		-NEXT LDX IP
308		- LEAX 1,X ; pre-increment mode
309		- LEAX 1,X ;
310		- STX IP
311		-NEXT2 LDX 0,X get W which points to CFA of word to be done
312		-NEXT3 STX W
313		- LDX 0,X get VECT which points to executable code
314		-* =
315		-* The next instruction could be patched to JMP TRACE =
316		-* if a TRACE routine is available: =
317		-* =
318		- JMP 0,X
319		- NOP
320		-* JMP TRACE ( an alternate for the above )
321		-* =
322		-* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
323		-
324		-
325		- PAGE
326		-*
327		-* ======>> 1 <<
328		- FCB $83
329		- FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
330		- FCB $D4
331		- FDB 0 link of zero to terminate dictionary scan
332		-LIT FDB *+2
333		- LDX IP
334		- LEAX 1,X ;
335		- LEAX 1,X ;
336		- STX IP
337		- LDA 0,X
338		- LDB 1,X
339		- JMP PUSHBA
340		-*
341		-* ######>> screen 14 <<
342		-* ======>> 2 <<
343		-CLITER FDB *+2 (this is an invisible word, with no header)
344		- LDX IP
345		- LEAX 1,X ;
346		- STX IP
347		- CLRA ;
348		- LDB 1,X
349		- JMP PUSHBA
350		-*
351		-* ======>> 3 <<
352		- FCB $87
353		- FCC 'EXECUT' ; 'EXECUTE'
354		- FCB $C5
355		- FDB LIT-6
356		-EXEC FDB *+2
357		- TFR S,X ; TSX :
358		- LDX 0,X get code field address (CFA)
359		- LEAS 1,S ; pop stack
360		- LEAS 1,S ;
361		- JMP NEXT3
362		-*
363		-* ######>> screen 15 <<
364		-* ======>> 4 <<
365		- FCB $86
366		- FCC 'BRANC' ; 'BRANCH'
367		- FCB $C8
368		- FDB EXEC-10
369		-BRAN FDB ZBYES Go steal code in ZBRANCH
370		-*
371		-* ======>> 5 <<
372		- FCB $87
373		- FCC '0BRANC' ; '0BRANCH'
374		- FCB $C8
375		- FDB BRAN-9
376		-ZBRAN FDB *+2
377		- PULS A ;
378		- PULS B ;
379		- PSHS B ; ** emulating ABA:
380		- ADDA ,S+ ;
381		- BNE ZBNO
382		- BCS ZBNO
383		-ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
384		- LDB 3,X
385		- LDA 2,X
386		- ADDB IP+1
387		- ADCA IP
388		- STB IP+1
389		- STA IP
390		- JMP NEXT
391		-ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
392		- LEAX 1,X ; jump over branch delta
393		- LEAX 1,X ;
394		- STX IP
395		- JMP NEXT
396		-*
397		-* ######>> screen 16 <<
398		-* ======>> 6 <<
399		- FCB $86
400		- FCC '(LOOP' ; '(LOOP)'
401		- FCB $A9
402		- FDB ZBRAN-10
403		-XLOOP FDB *+2
404		- CLRA ;
405		- LDB #1 get set to increment counter by 1
406		- BRA XPLOP2 go steal other guy's code!
407		-*
408		-* ======>> 7 <<
409		- FCB $87
410		- FCC '(+LOOP' ; '(+LOOP)'
411		- FCB $A9
412		- FDB XLOOP-9
413		-XPLOOP FDB *+2 Note: +LOOP has an un-signed loop counter
414		- PULS A ; get increment
415		- PULS B ;
416		-XPLOP2 TSTA ;
417		- BPL XPLOF forward looping
418		- BSR XPLOPS
419		- ORCC #$01 ; SEC :
420		- SBCB 5,X
421		- SBCA 4,X
422		- BPL ZBYES
423		- BRA XPLONO fall through
424		-*
425		-* the subroutine :
426		-XPLOPS LDX RP
427		- ADDB 3,X add it to counter
428		- ADCA 2,X
429		- STB 3,X store new counter value
430		- STA 2,X
431		- RTS
432		-*
433		-XPLOF BSR XPLOPS
434		- SUBB 5,X
435		- SBCA 4,X
436		- BMI ZBYES
437		-*
438		-XPLONO LEAX 1,X ; done, don't branch back
439		- LEAX 1,X ;
440		- LEAX 1,X ;
441		- LEAX 1,X ;
442		- STX RP
443		- BRA ZBNO use ZBRAN to skip over unused delta
444		-*
445		-* ######>> screen 17 <<
446		-* ======>> 8 <<
447		- FCB $84
448		- FCC '(DO' ; '(DO)'
449		- FCB $A9
450		- FDB XPLOOP-10
451		-XDO FDB *+2 This is the RUNTIME DO, not the COMPILING DO
452		- LDX RP
453		- LEAX -1,X ;
454		- LEAX -1,X ;
455		- LEAX -1,X ;
456		- LEAX -1,X ;
457		- STX RP
458		- PULS A ;
459		- PULS B ;
460		- STA 2,X
461		- STB 3,X
462		- PULS A ;
463		- PULS B ;
464		- STA 4,X
465		- STB 5,X
466		- JMP NEXT
467		-*
468		-* ======>> 9 <<
469		- FCB $81 I
470		- FCB $C9
471		- FDB XDO-7
472		-I FDB *+2
473		- LDX RP
474		- LEAX 1,X ;
475		- LEAX 1,X ;
476		- JMP GETX
477		-*
478		-* ######>> screen 18 <<
479		-* ======>> 10 <<
480		- FCB $85
481		- FCC 'DIGI' ; 'DIGIT'
482		- FCB $D4
483		- FDB I-4
484		-DIGIT FDB *+2 NOTE: legal input range is 0-9, A-Z
485		- TFR S,X ; TSX :
486		- LDA 3,X
487		- SUBA #$30 ascii zero
488		- BMI DIGIT2 IF LESS THAN '0', ILLEGAL
489		- CMPA #$A
490		- BMI DIGIT0 IF '9' OR LESS
491		- CMPA #$11
492		- BMI DIGIT2 if less than 'A'
493		- CMPA #$2B
494		- BPL DIGIT2 if greater than 'Z'
495		- SUBA #7 translate 'A' thru 'F'
496		-DIGIT0 CMPA 1,X
497		- BPL DIGIT2 if not less than the base
498		- LDB #1 set flag
499		- STA 3,X store digit
500		-DIGIT1 STB 1,X store the flag
501		- JMP NEXT
502		-DIGIT2 CLRB ;
503		- LEAS 1,S ;
504		- LEAS 1,S ; pop bottom number
505		- TFR S,X ; TSX :
506		- STB 0,X make sure both bytes are 00
507		- BRA DIGIT1
508		-*
509		-* ######>> screen 19 <<
510		-*
511		-* The word format in the dictionary is:
512		-*
513		-* char-count + $80 lowest address
514		-* char 1
515		-* char 2
516		-*
517		-* char n + $80
518		-* link high byte \___point to previous word
519		-* link low byte /
520		-* CFA high byte \___pnt to 6800 code
521		-* CFA low byte /
522		-* parameter fields
523		-* "
524		-* "
525		-* "
526		-*
527		-* ======>> 11 <<
528		- FCB $86
529		- FCC '(FIND' ; '(FIND)'
530		- FCB $A9
531		- FDB DIGIT-8
532		-PFIND FDB *+2
533		- NOP
534		- NOP
535		-PD EQU N ptr to dict word being checked
536		-PA0 EQU N+2
537		-PA EQU N+4
538		-PC EQU N+6
539		- LDX #PD
540		- LDB #4
541		-PFIND0 PULS A ; loop to get arguments
542		- STA 0,X
543		- LEAX 1,X ;
544		- DECB ;
545		- BNE PFIND0
546		-*
547		- LDX PD
548		-PFIND1 LDB 0,X get count dict count
549		- STB PC
550		- ANDB #$3F
551		- LEAX 1,X ;
552		- STX PD update PD
553		- LDX PA0
554		- LDA 0,X get count from arg
555		- LEAX 1,X ;
556		- STX PA intialize PA
557		- PSHS B ; ** emulating CBA:
558		- CMPA ,S+ ; compare lengths
559		- BNE PFIND4
560		-PFIND2 LDX PA
561		- LDA 0,X
562		- LEAX 1,X ;
563		- STX PA
564		- LDX PD
565		- LDB 0,X
566		- LEAX 1,X ;
567		- STX PD
568		- TSTB ; is dict entry neg. ?
569		- BPL PFIND8
570		- ANDB #$7F clear sign
571		- PSHS B ; ** emulating CBA:
572		- CMPA ,S+ ;
573		- BEQ FOUND
574		-PFIND3 LDX 0,X get new link
575		- BNE PFIND1 continue if link not=0
576		-*
577		-* not found :
578		-*
579		- CLRA ;
580		- CLRB ;
581		- JMP PUSHBA
582		-PFIND8 PSHS B ; ** emulating CBA:
583		- CMPA ,S+ ;
584		- BEQ PFIND2
585		-PFIND4 LDX PD
586		-PFIND9 LDB 0,X scan forward to end of this name
587		- LEAX 1,X ;
588		- BPL PFIND9
589		- BRA PFIND3
590		-*
591		-* found :
592		-*
593		-FOUND LDA PD compute CFA
594		- LDB PD+1
595		- ADDB #4
596		- ADCA #0
597		- PSHS B ;
598		- PSHS A ;
599		- LDA PC
600		- PSHS A ;
601		- CLRA ;
602		- PSHS A ;
603		- LDB #1
604		- JMP PUSHBA
605		-*
606		- PSHS A ;
607		- CLRA ;
608		- PSHS A ;
609		- LDB #1
610		- JMP PUSHBA
611		-*
612		-* ######>> screen 20 <<
613		-* ======>> 12 <<
614		- FCB $87
615		- FCC 'ENCLOS' ; 'ENCLOSE'
616		- FCB $C5
617		- FDB PFIND-9
618		-* NOTE :
619		-* FC means offset (bytes) to First Character of next word
620		-* EW " " to End of Word
621		-* NC " " to Next Character to start next enclose at
622		-ENCLOS FDB *+2
623		- LEAS 1,S ;
624		- PULS B ; now, get the low byte, for an 8-bit delimiter
625		- TFR S,X ; TSX :
626		- LDX 0,X
627		- CLR N
628		-* wait for a non-delimiter or a NUL
629		-ENCL2 LDA 0,X
630		- BEQ ENCL6
631		- PSHS B ; ** emulating CBA:
632		- CMPA ,S+ ; CHECK FOR DELIM
633		- BNE ENCL3
634		- LEAX 1,X ;
635		- INC N
636		- BRA ENCL2
637		-* found first character. Push FC
638		-ENCL3 LDA N found first char.
639		- PSHS A ;
640		- CLRA ;
641		- PSHS A ;
642		-* wait for a delimiter or a NUL
643		-ENCL4 LDA 0,X
644		- BEQ ENCL7
645		- PSHS B ; ** emulating CBA:
646		- CMPA ,S+ ; ckech for delim.
647		- BEQ ENCL5
648		- LEAX 1,X ;
649		- INC N
650		- BRA ENCL4
651		-* found EW. Push it
652		-ENCL5 LDB N
653		- CLRA ;
654		- PSHS B ;
655		- PSHS A ;
656		-* advance and push NC
657		- INCB ;
658		- JMP PUSHBA
659		-* found NUL before non-delimiter, therefore there is no word
660		-ENCL6 LDB N found NUL
661		- PSHS B ;
662		- PSHS A ;
663		- INCB ;
664		- BRA ENCL7+2
665		-* found NUL following the word instead of SPACE
666		-ENCL7 LDB N
667		- PSHS B ; save EW
668		- PSHS A ;
669		-ENCL8 LDB N save NC
670		- JMP PUSHBA
671		-
672		- PAGE
673		-*
674		-* ######>> screen 21 <<
675		-* The next 4 words call system dependant I/O routines
676		-* which are listed after word "-->" ( lable: "arrow" )
677		-* in the dictionary.
678		-*
679		-* ======>> 13 <<
680		- FCB $84
681		- FCC 'EMI' ; 'EMIT'
682		- FCB $D4
683		- FDB ENCLOS-10
684		-EMIT FDB *+2
685		- PULS A ;
686		- PULS A ;
687		- JSR PEMIT
688		- LDX UP
689		- INC XOUT+1-UORIG,X
690		- BNE *+4 ;
691		- **WARNING** HARD OFFSET: +4 ***
692		- INC XOUT-UORIG,X
693		- JMP NEXT
694		-*
695		-* ======>> 14 <<
696		- FCB $83
697		- FCC 'KE' ; 'KEY'
698		- FCB $D9
699		- FDB EMIT-7
700		-KEY FDB *+2
701		- JSR PKEY
702		- PSHS A ;
703		- CLRA ;
704		- PSHS A ;
705		- JMP NEXT
706		-*
707		-* ======>> 15 <<
708		- FCB $89
709		- FCC '?TERMINA' ; '?TERMINAL'
710		- FCB $CC
711		- FDB KEY-6
712		-QTERM FDB *+2
713		- JSR PQTER
714		- CLRB ;
715		- JMP PUSHBA stack the flag
716		-*
717		-* ======>> 16 <<
718		- FCB $82
719		- FCC 'C' ; 'CR'
720		- FCB $D2
721		- FDB QTERM-12
722		-CR FDB *+2
723		- JSR PCR
724		- JMP NEXT
725		-*
726		-* ######>> screen 22 <<
727		-* ======>> 17 <<
728		- FCB $85
729		- FCC 'CMOV' ; 'CMOVE' : source, destination, count
730		- FCB $C5
731		- FDB CR-5
732		-CMOVE FDB +2 takes ( 43+47count cycles )
733		- LDX #N
734		- LDB #6
735		-CMOV1 PULS A ;
736		- STA 0,X move parameters to scratch area
737		- LEAX 1,X ;
738		- DECB ;
739		- BNE CMOV1
740		-CMOV2 LDA N
741		- LDB N+1
742		- SUBB #1
743		- SBCA #0
744		- STA N
745		- STB N+1
746		- BCS CMOV3
747		- LDX N+4
748		- LDA 0,X
749		- LEAX 1,X ;
750		- STX N+4
751		- LDX N+2
752		- STA 0,X
753		- LEAX 1,X ;
754		- STX N+2
755		- BRA CMOV2
756		-CMOV3 JMP NEXT
757		-*
758		-* ######>> screen 23 <<
759		-* ======>> 18 <<
760		- FCB $82
761		- FCC 'U' ; 'U*'
762		- FCB $AA
763		- FDB CMOVE-8
764		-USTAR FDB *+2
765		- BSR USTARS
766		- LEAS 1,S ;
767		- LEAS 1,S ;
768		- JMP PUSHBA
769		-*
770		-* The following is a subroutine which
771		-* multiplies top 2 words on stack,
772		-* leaving 32-bit result: high order word in A,B
773		-* low order word in 2nd word of stack.
774		-*
775		-USTARS LDA #16 bits/word counter
776		- PSHS A ;
777		- CLRA ;
778		- CLRB ;
779		- TFR S,X ; TSX :
780		-USTAR2 ROR 5,X shift multiplier
781		- ROR 6,X
782		- DEC 0,X done?
783		- BMI USTAR4
784		- BCC USTAR3
785		- ADDB 4,X
786		- ADCA 3,X
787		-USTAR3 RORA ;
788		- RORB ; shift result
789		- BRA USTAR2
790		-USTAR4 LEAS 1,S ; dump counter
791		- RTS
792		-*
793		-* ######>> screen 24 <<
794		-* ======>> 19 <<
795		- FCB $82
796		- FCC 'U' ; 'U/'
797		- FCB $AF
798		- FDB USTAR-5
799		-USLASH FDB *+2
800		- LDA #17
801		- PSHS A ;
802		- TFR S,X ; TSX :
803		- LDA 3,X
804		- LDB 4,X
805		-USL1 CMPA 1,X
806		- BHI USL3
807		- BCS USL2
808		- CMPB 2,X
809		- BCC USL3
810		-USL2 ANDCC #~$01 ; CLC :
811		- BRA USL4
812		-USL3 SUBB 2,X
813		- SBCA 1,X
814		- ORCC #$01 ; SEC :
815		-USL4 ROL 6,X
816		- ROL 5,X
817		- DEC 0,X
818		- BEQ USL5
819		- ROLB ;
820		- ROLA ;
821		- BCC USL1
822		- BRA USL3
823		-USL5 LEAS 1,S ;
824		- LEAS 1,S ;
825		- LEAS 1,S ;
826		- LEAS 1,S ;
827		- LEAS 1,S ;
828		- JMP SWAP+4 reverse quotient & remainder
829		-*
830		-* ######>> screen 25 <<
831		-* ======>> 20 <<
832		- FCB $83
833		- FCC 'AN' ; 'AND'
834		- FCB $C4
835		- FDB USLASH-5
836		-AND FDB *+2
837		- PULS A ;
838		- PULS B ;
839		- TFR S,X ; TSX :
840		- ANDB 1,X
841		- ANDA 0,X
842		- JMP STABX
843		-*
844		-* ======>> 21 <<
845		- FCB $82
846		- FCC 'O' ; 'OR'
847		- FCB $D2
848		- FDB AND-6
849		-OR FDB *+2
850		- PULS A ;
851		- PULS B ;
852		- TFR S,X ; TSX :
853		- ORB 1,X
854		- ORA 0,X
855		- JMP STABX
856		-*
857		-* ======>> 22 <<
858		- FCB $83
859		- FCC 'XO' ; 'XOR'
860		- FCB $D2
861		- FDB OR-5
862		-XOR FDB *+2
863		- PULS A ;
864		- PULS B ;
865		- TFR S,X ; TSX :
866		- EORB 1,X
867		- EORA 0,X
868		- JMP STABX
869		-*
870		-* ######>> screen 26 <<
871		-* ======>> 23 <<
872		- FCB $83
873		- FCC 'SP' ; 'SP@'
874		- FCB $C0
875		- FDB XOR-6
876		-SPAT FDB *+2
877		- TFR S,X ; TSX :
878		- STX N scratch area
879		- LDX #N
880		- JMP GETX
881		-*
882		-* ======>> 24 <<
883		- FCB $83
884		- FCC 'SP' ; 'SP!'
885		- FCB $A1
886		- FDB SPAT-6
887		-SPSTOR FDB *+2
888		- LDX UP
889		- LDX XSPZER-UORIG,X
890		- TFR X,S ; TXS : watch it ! X and S are not equal.
891		- JMP NEXT
892		-* ======>> 25 <<
893		- FCB $83
894		- FCC 'RP' ; 'RP!'
895		- FCB $A1
896		- FDB SPSTOR-6
897		-RPSTOR FDB *+2
898		- LDX RINIT initialize from rom constant
899		- STX RP
900		- JMP NEXT
901		-*
902		-* ======>> 26 <<
903		- FCB $82
904		- FCC ';' ; ';S'
905		- FCB $D3
906		- FDB RPSTOR-6
907		-SEMIS FDB *+2
908		- LDX RP
909		- LEAX 1,X ;
910		- LEAX 1,X ;
911		- STX RP
912		- LDX 0,X get address we have just finished.
913		- JMP NEXT+2 increment the return address & do next word
914		-*
915		-* ######>> screen 27 <<
916		-* ======>> 27 <<
917		- FCB $85
918		- FCC 'LEAV' ; 'LEAVE'
919		- FCB $C5
920		- FDB SEMIS-5
921		-LEAVE FDB *+2
922		- LDX RP
923		- LDA 2,X
924		- LDB 3,X
925		- STA 4,X
926		- STB 5,X
927		- JMP NEXT
928		-*
929		-* ======>> 28 <<
930		- FCB $82
931		- FCC '>' ; '>R'
932		- FCB $D2
933		- FDB LEAVE-8
934		-TOR FDB *+2
935		- LDX RP
936		- LEAX -1,X ;
937		- LEAX -1,X ;
938		- STX RP
939		- PULS A ;
940		- PULS B ;
941		- STA 2,X
942		- STB 3,X
943		- JMP NEXT
944		-*
945		-* ======>> 29 <<
946		- FCB $82
947		- FCC 'R' ; 'R>'
948		- FCB $BE
949		- FDB TOR-5
950		-FROMR FDB *+2
951		- LDX RP
952		- LDA 2,X
953		- LDB 3,X
954		- LEAX 1,X ;
955		- LEAX 1,X ;
956		- STX RP
957		- JMP PUSHBA
958		-*
959		-* ======>> 30 <<
960		- FCB $81 R
961		- FCB $D2
962		- FDB FROMR-5
963		-R FDB *+2
964		- LDX RP
965		- LEAX 1,X ;
966		- LEAX 1,X ;
967		- JMP GETX
968		-*
969		-* ######>> screen 28 <<
970		-* ======>> 31 <<
971		- FCB $82
972		- FCC '0' ; '0='
973		- FCB $BD
974		- FDB R-4
975		-ZEQU FDB *+2
976		- TFR S,X ; TSX :
977		- CLRA ;
978		- CLRB ;
979		- LDX 0,X
980		- BNE ZEQU2
981		- INCB ;
982		-ZEQU2 TFR S,X ; TSX :
983		- JMP STABX
984		-*
985		-* ======>> 32 <<
986		- FCB $82
987		- FCC '0' ; '0<'
988		- FCB $BC
989		- FDB ZEQU-5
990		-ZLESS FDB *+2
991		- TFR S,X ; TSX :
992		- LDA #$80 check the sign bit
993		- ANDA 0,X
994		- BEQ ZLESS2
995		- CLRA ; if neg.
996		- LDB #1
997		- JMP STABX
998		-ZLESS2 CLRB ;
999		- JMP STABX
1000		-*
1001		-* ######>> screen 29 <<
1002		-* ======>> 33 <<
1003		- FCB $81 '+'
1004		- FCB $AB
1005		- FDB ZLESS-5
1006		-PLUS FDB *+2
1007		- PULS A ;
1008		- PULS B ;
1009		- TFR S,X ; TSX :
1010		- ADDB 1,X
1011		- ADCA 0,X
1012		- JMP STABX
1013		-*
1014		-* ======>> 34 <<
1015		- FCB $82
1016		- FCC 'D' ; 'D+'
1017		- FCB $AB
1018		- FDB PLUS-4
1019		-DPLUS FDB *+2
1020		- TFR S,X ; TSX :
1021		- ANDCC #~$01 ; CLC :
1022		- LDB #4
1023		-DPLUS2 LDA 3,X
1024		- ADCA 7,X
1025		- STA 7,X
1026		- LEAX -1,X ;
1027		- DECB ;
1028		- BNE DPLUS2
1029		- LEAS 1,S ;
1030		- LEAS 1,S ;
1031		- LEAS 1,S ;
1032		- LEAS 1,S ;
1033		- JMP NEXT
1034		-*
1035		-* ======>> 35 <<
1036		- FCB $85
1037		- FCC 'MINU' ; 'MINUS'
1038		- FCB $D3
1039		- FDB DPLUS-5
1040		-MINUS FDB *+2
1041		- TFR S,X ; TSX :
1042		- NEG 1,X
1043		- BCC MINUS2
1044		- NEG 0,X
1045		- BRA MINUS3
1046		-MINUS2 COM 0,X
1047		-MINUS3 JMP NEXT
1048		-*
1049		-* ======>> 36 <<
1050		- FCB $86
1051		- FCC 'DMINU' ; 'DMINUS'
1052		- FCB $D3
1053		- FDB MINUS-8
1054		-DMINUS FDB *+2
1055		- TFR S,X ; TSX :
1056		- COM 0,X
1057		- COM 1,X
1058		- COM 2,X
1059		- NEG 3,X
1060		- BNE DMINX
1061		- INC 2,X
1062		- BNE DMINX
1063		- INC 1,X
1064		- BNE DMINX
1065		- INC 0,X
1066		-DMINX JMP NEXT
1067		-*
1068		-* ######>> screen 30 <<
1069		-* ======>> 37 <<
1070		- FCB $84
1071		- FCC 'OVE' ; 'OVER'
1072		- FCB $D2
1073		- FDB DMINUS-9
1074		-OVER FDB *+2
1075		- TFR S,X ; TSX :
1076		- LDA 2,X
1077		- LDB 3,X
1078		- JMP PUSHBA
1079		-*
1080		-* ======>> 38 <<
1081		- FCB $84
1082		- FCC 'DRO' ; 'DROP'
1083		- FCB $D0
1084		- FDB OVER-7
1085		-DROP FDB *+2
1086		- LEAS 1,S ;
1087		- LEAS 1,S ;
1088		- JMP NEXT
1089		-*
1090		-* ======>> 39 <<
1091		- FCB $84
1092		- FCC 'SWA' ; 'SWAP'
1093		- FCB $D0
1094		- FDB DROP-7
1095		-SWAP FDB *+2
1096		- PULS A ;
1097		- PULS B ;
1098		- TFR S,X ; TSX :
1099		- LDX 0,X
1100		- LEAS 1,S ;
1101		- LEAS 1,S ;
1102		- PSHS B ;
1103		- PSHS A ;
1104		- STX N
1105		- LDX #N
1106		- JMP GETX
1107		-*
1108		-* ======>> 40 <<
1109		- FCB $83
1110		- FCC 'DU' ; 'DUP'
1111		- FCB $D0
1112		- FDB SWAP-7
1113		-DUP FDB *+2
1114		- PULS A ;
1115		- PULS B ;
1116		- PSHS B ;
1117		- PSHS A ;
1118		- JMP PUSHBA
1119		-*
1120		-* ######>> screen 31 <<
1121		-* ======>> 41 <<
1122		- FCB $82
1123		- FCC '+' ; '+!'
1124		- FCB $A1
1125		- FDB DUP-6
1126		-PSTORE FDB *+2
1127		- TFR S,X ; TSX :
1128		- LDX 0,X
1129		- LEAS 1,S ;
1130		- LEAS 1,S ;
1131		- PULS A ; get stack data
1132		- PULS B ;
1133		- ADDB 1,X add & store low byte
1134		- STB 1,X
1135		- ADCA 0,X add & store hi byte
1136		- STA 0,X
1137		- JMP NEXT
1138		-*
1139		-* ======>> 42 <<
1140		- FCB $86
1141		- FCC 'TOGGL' ; 'TOGGLE'
1142		- FCB $C5
1143		- FDB PSTORE-5
1144		-TOGGLE FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
1145		- FDB SEMIS
1146		-*
1147		-* ######>> screen 32 <<
1148		-* ======>> 43 <<
1149		- FCB $81 @
1150		- FCB $C0
1151		- FDB TOGGLE-9
1152		-AT FDB *+2
1153		- TFR S,X ; TSX :
1154		- LDX 0,X get address
1155		- LEAS 1,S ;
1156		- LEAS 1,S ;
1157		- JMP GETX
1158		-*
1159		-* ======>> 44 <<
1160		- FCB $82
1161		- FCC 'C' ; 'C@'
1162		- FCB $C0
1163		- FDB AT-4
1164		-CAT FDB *+2
1165		- TFR S,X ; TSX :
1166		- LDX 0,X
1167		- CLRA ;
1168		- LDB 0,X
1169		- LEAS 1,S ;
1170		- LEAS 1,S ;
1171		- JMP PUSHBA
1172		-*
1173		-* ======>> 45 <<
1174		- FCB $81
1175		- FCB $A1
1176		- FDB CAT-5
1177		-STORE FDB *+2
1178		- TFR S,X ; TSX :
1179		- LDX 0,X get address
1180		- LEAS 1,S ;
1181		- LEAS 1,S ;
1182		- JMP PULABX
1183		-*
1184		-* ======>> 46 <<
1185		- FCB $82
1186		- FCC 'C' ; 'C!'
1187		- FCB $A1
1188		- FDB STORE-4
1189		-CSTORE FDB *+2
1190		- TFR S,X ; TSX :
1191		- LDX 0,X get address
1192		- LEAS 1,S ;
1193		- LEAS 1,S ;
1194		- LEAS 1,S ;
1195		- PULS B ;
1196		- STB 0,X
1197		- JMP NEXT
1198		- PAGE
1199		-*
1200		-* ######>> screen 33 <<
1201		-* ======>> 47 <<
1202		- FCB $C1 : immediate
1203		- FCB $BA
1204		- FDB CSTORE-5
1205		-COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
1206		- FDB CREATE,RBRAK
1207		- FDB PSCODE
1208		-
1209		-* Here is the IP pusher for allowing
1210		-* nested words in the virtual machine:
1211		-* ( ;S is the equivalent un-nester )
1212		-
1213		-DOCOL LDX RP make room in the stack
1214		- LEAX -1,X ;
1215		- LEAX -1,X ;
1216		- STX RP
1217		- LDA IP
1218		- LDB IP+1
1219		- STA 2,X Store address of the high level word
1220		- STB 3,X that we are starting to execute
1221		- LDX W Get first sub-word of that definition
1222		- JMP NEXT+2 and execute it
1223		-*
1224		-* ======>> 48 <<
1225		- FCB $C1 ; imnediate code
1226		- FCB $BB
1227		- FDB COLON-4
1228		-SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
1229		- FDB SEMIS
1230		-*
1231		-* ######>> screen 34 <<
1232		-* ======>> 49 <<
1233		- FCB $88
1234		- FCC 'CONSTAN' ; 'CONSTANT'
1235		- FCB $D4
1236		- FDB SEMI-4
1237		-CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
1238		-DOCON LDX W
1239		- LDA 2,X
1240		- LDB 3,X A & B now contain the constant
1241		- JMP PUSHBA
1242		-*
1243		-* ======>> 50 <<
1244		- FCB $88
1245		- FCC 'VARIABL' ; 'VARIABLE'
1246		- FCB $C5
1247		- FDB CON-11
1248		-VAR FDB DOCOL,CON,PSCODE
1249		-DOVAR LDA W
1250		- LDB W+1
1251		- ADDB #2
1252		- ADCA #0 A,B now contain the address of the variable
1253		- JMP PUSHBA
1254		-*
1255		-* ======>> 51 <<
1256		- FCB $84
1257		- FCC 'USE' ; 'USER'
1258		- FCB $D2
1259		- FDB VAR-11
1260		-USER FDB DOCOL,CON,PSCODE
1261		-DOUSER LDX W get offset into user's table
1262		- LDA 2,X
1263		- LDB 3,X
1264		- ADDB UP+1 add to users base address
1265		- ADCA UP
1266		- JMP PUSHBA push address of user's variable
1267		-*
1268		-* ######>> screen 35 <<
1269		-* ======>> 52 <<
1270		- FCB $81
1271		- FCB $B0 0
1272		- FDB USER-7
1273		-ZERO FDB DOCON
1274		- FDB 0000
1275		-*
1276		-* ======>> 53 <<
1277		- FCB $81
1278		- FCB $B1 1
1279		- FDB ZERO-4
1280		-ONE FDB DOCON
1281		- FDB 1
1282		-*
1283		-* ======>> 54 <<
1284		- FCB $81
1285		- FCB $B2 2
1286		- FDB ONE-4
1287		-TWO FDB DOCON
1288		- FDB 2
1289		-*
1290		-* ======>> 55 <<
1291		- FCB $81
1292		- FCB $B3 3
1293		- FDB TWO-4
1294		-THREE FDB DOCON
1295		- FDB 3
1296		-*
1297		-* ======>> 56 <<
1298		- FCB $82
1299		- FCC 'B' ; 'BL'
1300		- FCB $CC
1301		- FDB THREE-4
1302		-BL FDB DOCON ascii blank
1303		- FDB $20
1304		-*
1305		-* ======>> 57 <<
1306		- FCB $85
1307		- FCC 'FIRS' ; 'FIRST'
1308		- FCB $D4
1309		- FDB BL-5
1310		-FIRST FDB DOCON
1311		- FDB MEMEND-528 (132 * NBLK)
1312		-*
1313		-* ======>> 58 <<
1314		- FCB $85
1315		- FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
1316		- FCB $D4
1317		- FDB FIRST-8
1318		-LIMIT FDB DOCON
1319		- FDB MEMEND
1320		-*
1321		-* ======>> 59 <<
1322		- FCB $85
1323		- FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
1324		- FCB $C6
1325		- FDB LIMIT-8
1326		-BBUF FDB DOCON
1327		- FDB 128
1328		-*
1329		-* ======>> 60 <<
1330		- FCB $85
1331		- FCC 'B/SC' ; 'B/SCR' : (blocks/screen)
1332		- FCB $D2
1333		- FDB BBUF-8
1334		-BSCR FDB DOCON
1335		- FDB 8
1336		-* blocks/screen = 1024 / "B/BUF" = 8
1337		-*
1338		-* ======>> 61 <<
1339		- FCB $87
1340		- FCC '+ORIGI' ; '+ORIGIN'
1341		- FCB $CE
1342		- FDB BSCR-8
1343		-PORIG FDB DOCOL,LIT,ORIG,PLUS
1344		- FDB SEMIS
1345		-*
1346		-* ######>> screen 36 <<
1347		-* ======>> 62 <<
1348		- FCB $82
1349		- FCC 'S' ; 'S0'
1350		- FCB $B0
1351		- FDB PORIG-10
1352		-SZERO FDB DOUSER
1353		- FDB XSPZER-UORIG
1354		-*
1355		-* ======>> 63 <<
1356		- FCB $82
1357		- FCC 'R' ; 'R0'
1358		- FCB $B0
1359		- FDB SZERO-5
1360		-RZERO FDB DOUSER
1361		- FDB XRZERO-UORIG
1362		-*
1363		-* ======>> 64 <<
1364		- FCB $83
1365		- FCC 'TI' ; 'TIB'
1366		- FCB $C2
1367		- FDB RZERO-5
1368		-TIB FDB DOUSER
1369		- FDB XTIB-UORIG
1370		-*
1371		-* ======>> 65 <<
1372		- FCB $85
1373		- FCC 'WIDT' ; 'WIDTH'
1374		- FCB $C8
1375		- FDB TIB-6
1376		-WIDTH FDB DOUSER
1377		- FDB XWIDTH-UORIG
1378		-*
1379		-* ======>> 66 <<
1380		- FCB $87
1381		- FCC 'WARNIN' ; 'WARNING'
1382		- FCB $C7
1383		- FDB WIDTH-8
1384		-WARN FDB DOUSER
1385		- FDB XWARN-UORIG
1386		-*
1387		-* ======>> 67 <<
1388		- FCB $85
1389		- FCC 'FENC' ; 'FENCE'
1390		- FCB $C5
1391		- FDB WARN-10
1392		-FENCE FDB DOUSER
1393		- FDB XFENCE-UORIG
1394		-*
1395		-* ======>> 68 <<
1396		- FCB $82
1397		- FCC 'D' ; 'DP' : points to first free byte at end of dictionary
1398		- FCB $D0
1399		- FDB FENCE-8
1400		-DP FDB DOUSER
1401		- FDB XDP-UORIG
1402		-*
1403		-* ======>> 68.5 <<
1404		- FCB $88
1405		- FCC 'VOC-LIN' ; 'VOC-LINK'
1406		- FCB $CB
1407		- FDB DP-5
1408		-VOCLIN FDB DOUSER
1409		- FDB XVOCL-UORIG
1410		-*
1411		-* ======>> 69 <<
1412		- FCB $83
1413		- FCC 'BL' ; 'BLK'
1414		- FCB $CB
1415		- FDB VOCLIN-11
1416		-BLK FDB DOUSER
1417		- FDB XBLK-UORIG
1418		-*
1419		-* ======>> 70 <<
1420		- FCB $82
1421		- FCC 'I' ; 'IN' : scan pointer for input line buffer
1422		- FCB $CE
1423		- FDB BLK-6
1424		-IN FDB DOUSER
1425		- FDB XIN-UORIG
1426		-*
1427		-* ======>> 71 <<
1428		- FCB $83
1429		- FCC 'OU' ; 'OUT'
1430		- FCB $D4
1431		- FDB IN-5
1432		-OUT FDB DOUSER
1433		- FDB XOUT-UORIG
1434		-*
1435		-* ======>> 72 <<
1436		- FCB $83
1437		- FCC 'SC' ; 'SCR'
1438		- FCB $D2
1439		- FDB OUT-6
1440		-SCR FDB DOUSER
1441		- FDB XSCR-UORIG
1442		-* ######>> screen 37 <<
1443		-*
1444		-* ======>> 73 <<
1445		- FCB $86
1446		- FCC 'OFFSE' ; 'OFFSET'
1447		- FCB $D4
1448		- FDB SCR-6
1449		-OFSET FDB DOUSER
1450		- FDB XOFSET-UORIG
1451		-*
1452		-* ======>> 74 <<
1453		- FCB $87
1454		- FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
1455		- FCB $D4
1456		- FDB OFSET-9
1457		-CONTXT FDB DOUSER
1458		- FDB XCONT-UORIG
1459		-*
1460		-* ======>> 75 <<
1461		- FCB $87
1462		- FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
1463		- FCB $D4
1464		- FDB CONTXT-10
1465		-CURENT FDB DOUSER
1466		- FDB XCURR-UORIG
1467		-*
1468		-* ======>> 76 <<
1469		- FCB $85
1470		- FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
1471		- FCB $C5
1472		- FDB CURENT-10
1473		-STATE FDB DOUSER
1474		- FDB XSTATE-UORIG
1475		-*
1476		-* ======>> 77 <<
1477		- FCB $84
1478		- FCC 'BAS' ; 'BASE' : number base for all input & output
1479		- FCB $C5
1480		- FDB STATE-8
1481		-BASE FDB DOUSER
1482		- FDB XBASE-UORIG
1483		-*
1484		-* ======>> 78 <<
1485		- FCB $83
1486		- FCC 'DP' ; 'DPL'
1487		- FCB $CC
1488		- FDB BASE-7
1489		-DPL FDB DOUSER
1490		- FDB XDPL-UORIG
1491		-*
1492		-* ======>> 79 <<
1493		- FCB $83
1494		- FCC 'FL' ; 'FLD'
1495		- FCB $C4
1496		- FDB DPL-6
1497		-FLD FDB DOUSER
1498		- FDB XFLD-UORIG
1499		-*
1500		-* ======>> 80 <<
1501		- FCB $83
1502		- FCC 'CS' ; 'CSP'
1503		- FCB $D0
1504		- FDB FLD-6
1505		-CSP FDB DOUSER
1506		- FDB XCSP-UORIG
1507		-*
1508		-* ======>> 81 <<
1509		- FCB $82
1510		- FCC 'R' ; 'R#'
1511		- FCB $A3
1512		- FDB CSP-6
1513		-RNUM FDB DOUSER
1514		- FDB XRNUM-UORIG
1515		-*
1516		-* ======>> 82 <<
1517		- FCB $83
1518		- FCC 'HL' ; 'HLD'
1519		- FCB $C4
1520		- FDB RNUM-5
1521		-HLD FDB DOCON
1522		- FDB XHLD
1523		-*
1524		-* ======>> 82.5 <<== SPECIAL
1525		- FCB $87
1526		- FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
1527		- FCB $D3
1528		- FDB HLD-6
1529		-COLUMS FDB DOUSER
1530		- FDB XCOLUM-UORIG
1531		-*
1532		-* ######>> screen 38 <<
1533		-* ======>> 83 <<
1534		- FCB $82
1535		- FCC '1' ; '1+'
1536		- FCB $AB
1537		- FDB COLUMS-10
1538		-ONEP FDB DOCOL,ONE,PLUS
1539		- FDB SEMIS
1540		-*
1541		-* ======>> 84 <<
1542		- FCB $82
1543		- FCC '2' ; '2+'
1544		- FCB $AB
1545		- FDB ONEP-5
1546		-TWOP FDB DOCOL,TWO,PLUS
1547		- FDB SEMIS
1548		-*
1549		-* ======>> 85 <<
1550		- FCB $84
1551		- FCC 'HER' ; 'HERE'
1552		- FCB $C5
1553		- FDB TWOP-5
1554		-HERE FDB DOCOL,DP,AT
1555		- FDB SEMIS
1556		-*
1557		-* ======>> 86 <<
1558		- FCB $85
1559		- FCC 'ALLO' ; 'ALLOT'
1560		- FCB $D4
1561		- FDB HERE-7
1562		-ALLOT FDB DOCOL,DP,PSTORE
1563		- FDB SEMIS
1564		-*
1565		-* ======>> 87 <<
1566		- FCB $81 ; , (COMMA)
1567		- FCB $AC
1568		- FDB ALLOT-8
1569		-COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
1570		- FDB SEMIS
1571		-*
1572		-* ======>> 88 <<
1573		- FCB $82
1574		- FCC 'C' ; 'C,'
1575		- FCB $AC
1576		- FDB COMMA-4
1577		-CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
1578		- FDB SEMIS
1579		-*
1580		-* ======>> 89 <<
1581		- FCB $81 ; -
1582		- FCB $AD
1583		- FDB CCOMM-5
1584		-SUB FDB DOCOL,MINUS,PLUS
1585		- FDB SEMIS
1586		-*
1587		-* ======>> 90 <<
1588		- FCB $81 =
1589		- FCB $BD
1590		- FDB SUB-4
1591		-EQUAL FDB DOCOL,SUB,ZEQU
1592		- FDB SEMIS
1593		-*
1594		-* ======>> 91 <<
1595		- FCB $81 <
1596		- FCB $BC
1597		- FDB EQUAL-4
1598		-LESS FDB *+2
1599		- PULS A ;
1600		- PULS B ;
1601		- TFR S,X ; TSX :
1602		- CMPA 0,X
1603		- LEAS 1,S ;
1604		- BGT LESST
1605		- BNE LESSF
1606		- CMPB 1,X
1607		- BHI LESST
1608		-LESSF CLRB ;
1609		- BRA LESSX
1610		-LESST LDB #1
1611		-LESSX CLRA ;
1612		- LEAS 1,S ;
1613		- JMP PUSHBA
1614		-*
1615		-* ======>> 92 <<
1616		- FCB $81 >
1617		- FCB $BE
1618		- FDB LESS-4
1619		-GREAT FDB DOCOL,SWAP,LESS
1620		- FDB SEMIS
1621		-*
1622		-* ======>> 93 <<
1623		- FCB $83
1624		- FCC 'RO' ; 'ROT'
1625		- FCB $D4
1626		- FDB GREAT-4
1627		-ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
1628		- FDB SEMIS
1629		-*
1630		-* ======>> 94 <<
1631		- FCB $85
1632		- FCC 'SPAC' ; 'SPACE'
1633		- FCB $C5
1634		- FDB ROT-6
1635		-SPACE FDB DOCOL,BL,EMIT
1636		- FDB SEMIS
1637		-*
1638		-* ======>> 95 <<
1639		- FCB $83
1640		- FCC 'MI' ; 'MIN'
1641		- FCB $CE
1642		- FDB SPACE-8
1643		-MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
1644		- FDB MIN2-*
1645		- FDB SWAP
1646		-MIN2 FDB DROP
1647		- FDB SEMIS
1648		-*
1649		-* ======>> 96 <<
1650		- FCB $83
1651		- FCC 'MA' ; 'MAX'
1652		- FCB $D8
1653		- FDB MIN-6
1654		-MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
1655		- FDB MAX2-*
1656		- FDB SWAP
1657		-MAX2 FDB DROP
1658		- FDB SEMIS
1659		-*
1660		-* ======>> 97 <<
1661		- FCB $84
1662		- FCC '-DU' ; '-DUP'
1663		- FCB $D0
1664		- FDB MAX-6
1665		-DDUP FDB DOCOL,DUP,ZBRAN
1666		- FDB DDUP2-*
1667		- FDB DUP
1668		-DDUP2 FDB SEMIS
1669		-*
1670		-* ######>> screen 39 <<
1671		-* ======>> 98 <<
1672		- FCB $88
1673		- FCC 'TRAVERS' ; 'TRAVERSE'
1674		- FCB $C5
1675		- FDB DDUP-7
1676		-TRAV FDB DOCOL,SWAP
1677		-TRAV2 FDB OVER,PLUS,CLITER
1678		- FCB $7F
1679		- FDB OVER,CAT,LESS,ZBRAN
1680		- FDB TRAV2-*
1681		- FDB SWAP,DROP
1682		- FDB SEMIS
1683		-*
1684		-* ======>> 99 <<
1685		- FCB $86
1686		- FCC 'LATES' ; 'LATEST'
1687		- FCB $D4
1688		- FDB TRAV-11
1689		-LATEST FDB DOCOL,CURENT,AT,AT
1690		- FDB SEMIS
1691		-*
1692		-* ======>> 100 <<
1693		- FCB $83
1694		- FCC 'LF' ; 'LFA'
1695		- FCB $C1
1696		- FDB LATEST-9
1697		-LFA FDB DOCOL,CLITER
1698		- FCB 4
1699		- FDB SUB
1700		- FDB SEMIS
1701		-*
1702		-* ======>> 101 <<
1703		- FCB $83
1704		- FCC 'CF' ; 'CFA'
1705		- FCB $C1
1706		- FDB LFA-6
1707		-CFA FDB DOCOL,TWO,SUB
1708		- FDB SEMIS
1709		-*
1710		-* ======>> 102 <<
1711		- FCB $83
1712		- FCC 'NF' ; 'NFA'
1713		- FCB $C1
1714		- FDB CFA-6
1715		-NFA FDB DOCOL,CLITER
1716		- FCB 5
1717		- FDB SUB,ONE,MINUS,TRAV
1718		- FDB SEMIS
1719		-*
1720		-* ======>> 103 <<
1721		- FCB $83
1722		- FCC 'PF' ; 'PFA'
1723		- FCB $C1
1724		- FDB NFA-6
1725		-PFA FDB DOCOL,ONE,TRAV,CLITER
1726		- FCB 5
1727		- FDB PLUS
1728		- FDB SEMIS
1729		-*
1730		-* ######>> screen 40 <<
1731		-* ======>> 104 <<
1732		- FCB $84
1733		- FCC '!CS' ; '!CSP'
1734		- FCB $D0
1735		- FDB PFA-6
1736		-SCSP FDB DOCOL,SPAT,CSP,STORE
1737		- FDB SEMIS
1738		-*
1739		-* ======>> 105 <<
1740		- FCB $86
1741		- FCC '?ERRO' ; '?ERROR'
1742		- FCB $D2
1743		- FDB SCSP-7
1744		-QERR FDB DOCOL,SWAP,ZBRAN
1745		- FDB QERR2-*
1746		- FDB ERROR,BRAN
1747		- FDB QERR3-*
1748		-QERR2 FDB DROP
1749		-QERR3 FDB SEMIS
1750		-*
1751		-* ======>> 106 <<
1752		- FCB $85
1753		- FCC '?COM' ; '?COMP'
1754		- FCB $D0
1755		- FDB QERR-9
1756		-QCOMP FDB DOCOL,STATE,AT,ZEQU,CLITER
1757		- FCB $11
1758		- FDB QERR
1759		- FDB SEMIS
1760		-*
1761		-* ======>> 107 <<
1762		- FCB $85
1763		- FCC '?EXE' ; '?EXEC'
1764		- FCB $C3
1765		- FDB QCOMP-8
1766		-QEXEC FDB DOCOL,STATE,AT,CLITER
1767		- FCB $12
1768		- FDB QERR
1769		- FDB SEMIS
1770		-*
1771		-* ======>> 108 <<
1772		- FCB $86
1773		- FCC '?PAIR' ; '?PAIRS'
1774		- FCB $D3
1775		- FDB QEXEC-8
1776		-QPAIRS FDB DOCOL,SUB,CLITER
1777		- FCB $13
1778		- FDB QERR
1779		- FDB SEMIS
1780		-*
1781		-* ======>> 109 <<
1782		- FCB $84
1783		- FCC '?CS' ; '?CSP'
1784		- FCB $D0
1785		- FDB QPAIRS-9
1786		-QCSP FDB DOCOL,SPAT,CSP,AT,SUB,CLITER
1787		- FCB $14
1788		- FDB QERR
1789		- FDB SEMIS
1790		-*
1791		-* ======>> 110 <<
1792		- FCB $88
1793		- FCC '?LOADIN' ; '?LOADING'
1794		- FCB $C7
1795		- FDB QCSP-7
1796		-QLOAD FDB DOCOL,BLK,AT,ZEQU,CLITER
1797		- FCB $16
1798		- FDB QERR
1799		- FDB SEMIS
1800		-*
1801		-* ######>> screen 41 <<
1802		-* ======>> 111 <<
1803		- FCB $87
1804		- FCC 'COMPIL' ; 'COMPILE'
1805		- FCB $C5
1806		- FDB QLOAD-11
1807		-COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
1808		- FDB SEMIS
1809		-*
1810		-* ======>> 112 <<
1811		- FCB $C1 [ immediate
1812		- FCB $DB
1813		- FDB COMPIL-10
1814		-LBRAK FDB DOCOL,ZERO,STATE,STORE
1815		- FDB SEMIS
1816		-*
1817		-* ======>> 113 <<
1818		- FCB $81 ]
1819		- FCB $DD
1820		- FDB LBRAK-4
1821		-RBRAK FDB DOCOL,CLITER
1822		- FCB $C0
1823		- FDB STATE,STORE
1824		- FDB SEMIS
1825		-*
1826		-* ======>> 114 <<
1827		- FCB $86
1828		- FCC 'SMUDG' ; 'SMUDGE'
1829		- FCB $C5
1830		- FDB RBRAK-4
1831		-SMUDGE FDB DOCOL,LATEST,CLITER
1832		- FCB $20
1833		- FDB TOGGLE
1834		- FDB SEMIS
1835		-*
1836		-* ======>> 115 <<
1837		- FCB $83
1838		- FCC 'HE' ; 'HEX'
1839		- FCB $D8
1840		- FDB SMUDGE-9
1841		-HEX FDB DOCOL
1842		- FDB CLITER
1843		- FCB 16
1844		- FDB BASE,STORE
1845		- FDB SEMIS
1846		-*
1847		-* ======>> 116 <<
1848		- FCB $87
1849		- FCC 'DECIMA' ; 'DECIMAL'
1850		- FCB $CC
1851		- FDB HEX-6
1852		-DEC FDB DOCOL
1853		- FDB CLITER
1854		- FCB 10 note: hex "A"
1855		- FDB BASE,STORE
1856		- FDB SEMIS
1857		-*
1858		-* ######>> screen 42 <<
1859		-* ======>> 117 <<
1860		- FCB $87
1861		- FCC '(;CODE' ; '(;CODE)'
1862		- FCB $A9
1863		- FDB DEC-10
1864		-PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
1865		- FDB SEMIS
1866		-*
1867		-* ======>> 118 <<
1868		- FCB $C5 immediate
1869		- FCC ';COD' ; ';CODE'
1870		- FCB $C5
1871		- FDB PSCODE-10
1872		-SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
1873		- FDB SEMIS
1874		-* note: "QSTACK" will be replaced by "ASSEMBLER" later
1875		-*
1876		-* ######>> screen 43 <<
1877		-* ======>> 119 <<
1878		- FCB $87
1879		- FCC '<BUILD' ; '<BUILDS'
1880		- FCB $D3
1881		- FDB SEMIC-8
1882		-BUILDS FDB DOCOL,ZERO,CON
1883		- FDB SEMIS
1884		-*
1885		-* ======>> 120 <<
1886		- FCB $85
1887		- FCC 'DOES' ; 'DOES>'
1888		- FCB $BE
1889		- FDB BUILDS-10
1890		-DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
1891		- FDB PSCODE
1892		-DODOES LDA IP
1893		- LDB IP+1
1894		- LDX RP make room on return stack
1895		- LEAX -1,X ;
1896		- LEAX -1,X ;
1897		- STX RP
1898		- STA 2,X push return address
1899		- STB 3,X
1900		- LDX W get addr of pointer to run-time code
1901		- LEAX 1,X ;
1902		- LEAX 1,X ;
1903		- STX N stash it in scratch area
1904		- LDX 0,X get new IP
1905		- STX IP
1906		- CLRA ; get address of parameter
1907		- LDB #2
1908		- ADDB N+1
1909		- ADCA N
1910		- PSHS B ; and push it on data stack
1911		- PSHS A ;
1912		- JMP NEXT2
1913		-*
1914		-* ######>> screen 44 <<
1915		-* ======>> 121 <<
1916		- FCB $85
1917		- FCC 'COUN' ; 'COUNT'
1918		- FCB $D4
1919		- FDB DOES-8
1920		-COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
1921		- FDB SEMIS
1922		-*
1923		-* ======>> 122 <<
1924		- FCB $84
1925		- FCC 'TYP' ; 'TYPE'
1926		- FCB $C5
1927		- FDB COUNT-8
1928		-TYPE FDB DOCOL,DDUP,ZBRAN
1929		- FDB TYPE3-*
1930		- FDB OVER,PLUS,SWAP,XDO
1931		-TYPE2 FDB I,CAT,EMIT,XLOOP
1932		- FDB TYPE2-*
1933		- FDB BRAN
1934		- FDB TYPE4-*
1935		-TYPE3 FDB DROP
1936		-TYPE4 FDB SEMIS
1937		-*
1938		-* ======>> 123 <<
1939		- FCB $89
1940		- FCC '-TRAILIN' ; '-TRAILING'
1941		- FCB $C7
1942		- FDB TYPE-7
1943		-DTRAIL FDB DOCOL,DUP,ZERO,XDO
1944		-DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
1945		- FDB SUB,ZBRAN
1946		- FDB DTRAL3-*
1947		- FDB LEAVE,BRAN
1948		- FDB DTRAL4-*
1949		-DTRAL3 FDB ONE,SUB
1950		-DTRAL4 FDB XLOOP
1951		- FDB DTRAL2-*
1952		- FDB SEMIS
1953		-*
1954		-* ======>> 124 <<
1955		- FCB $84
1956		- FCC '(."' ; '(.")'
1957		- FCB $A9
1958		- FDB DTRAIL-12
1959		-PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
1960		- FDB FROMR,PLUS,TOR,TYPE
1961		- FDB SEMIS
1962		-*
1963		-* ======>> 125 <<
1964		- FCB $C2 immediate
1965		- FCC '.' ; '."'
1966		- FCB $A2
1967		- FDB PDOTQ-7
1968		-DOTQ FDB DOCOL
1969		- FDB CLITER
1970		- FCB $22 ascii quote
1971		- FDB STATE,AT,ZBRAN
1972		- FDB DOTQ1-*
1973		- FDB COMPIL,PDOTQ,WORD
1974		- FDB HERE,CAT,ONEP,ALLOT,BRAN
1975		- FDB DOTQ2-*
1976		-DOTQ1 FDB WORD,HERE,COUNT,TYPE
1977		-DOTQ2 FDB SEMIS
1978		-*
1979		-* ######>> screen 45 <<
1980		-* ======>> 126 <<== MACHINE DEPENDENT
1981		- FCB $86
1982		- FCC '?STAC' ; '?STACK'
1983		- FCB $CB
1984		- FDB DOTQ-5
1985		-QSTACK FDB DOCOL,CLITER
1986		- FCB $12
1987		- FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
1988		- FDB QERR
1989		-* prints 'empty stack'
1990		-*
1991		-QSTAC2 FDB SPAT
1992		-* Here, we compare with a value at least 128
1993		-* higher than dict. ptr. (DP)
1994		- FDB HERE,CLITER
1995		- FCB $80
1996		- FDB PLUS,LESS,ZBRAN
1997		- FDB QSTAC3-*
1998		- FDB TWO
1999		- FDB QERR
2000		-* prints 'full stack'
2001		-*
2002		-QSTAC3 FDB SEMIS
2003		-*
2004		-* ======>> 127 << this word's function
2005		-* is done by ?STACK in this version
2006		-* FCB $85
2007		-* FCC 4,?FREE
2008		-* FCB $C5
2009		-* FDB QSTACK-9
2010		-*QFREE FDB DOCOL,SPAT,HERE,CLITER
2011		-* FCB $80
2012		-* FDB PLUS,LESS,TWO,QERR,SEMIS
2013		-*
2014		-* ######>> screen 46 <<
2015		-* ======>> 128 <<
2016		- FCB $86
2017		- FCC 'EXPEC' ; 'EXPECT'
2018		- FCB $D4
2019		- FDB QSTACK-9
2020		-EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO
2021		-EXPEC2 FDB KEY,DUP,CLITER
2022		- FCB $0E
2023		- FDB PORIG,AT,EQUAL,ZBRAN
2024		- FDB EXPEC3-*
2025		- FDB DROP,CLITER
2026		- FCB 8 ( backspace character to emit )
2027		- FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS
2028		- FDB TOR,SUB,BRAN
2029		- FDB EXPEC6-*
2030		-EXPEC3 FDB DUP,CLITER
2031		- FCB $D ( carriage return )
2032		- FDB EQUAL,ZBRAN
2033		- FDB EXPEC4-*
2034		- FDB LEAVE,DROP,BL,ZERO,BRAN
2035		- FDB EXPEC5-*
2036		-EXPEC4 FDB DUP
2037		-EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
2038		-EXPEC6 FDB EMIT,XLOOP
2039		- FDB EXPEC2-*
2040		- FDB DROP
2041		- FDB SEMIS
2042		-*
2043		-* ======>> 129 <<
2044		- FCB $85
2045		- FCC 'QUER' ; 'QUERY'
2046		- FCB $D9
2047		- FDB EXPECT-9
2048		-QUERY FDB DOCOL,TIB,AT,COLUMS
2049		- FDB AT,EXPECT,ZERO,IN,STORE
2050		- FDB SEMIS
2051		-*
2052		-* ======>> 130 <<
2053		- FCB $C1 immediate < carriage return >
2054		- FCB $80
2055		- FDB QUERY-8
2056		-NULL FDB DOCOL,BLK,AT,ZBRAN
2057		- FDB NULL2-*
2058		- FDB ONE,BLK,PSTORE
2059		- FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
2060		- FDB ZEQU
2061		-* check for end of screen
2062		- FDB ZBRAN
2063		- FDB NULL1-*
2064		- FDB QEXEC,FROMR,DROP
2065		-NULL1 FDB BRAN
2066		- FDB NULL3-*
2067		-NULL2 FDB FROMR,DROP
2068		-NULL3 FDB SEMIS
2069		-*
2070		-* ######>> screen 47 <<
2071		-* ======>> 133 <<
2072		- FCB $84
2073		- FCC 'FIL' ; 'FILL'
2074		- FCB $CC
2075		- FDB NULL-4
2076		-FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
2077		- FDB FROMR,ONE,SUB,CMOVE
2078		- FDB SEMIS
2079		-*
2080		-* ======>> 134 <<
2081		- FCB $85
2082		- FCC 'ERAS' ; 'ERASE'
2083		- FCB $C5
2084		- FDB FILL-7
2085		-ERASE FDB DOCOL,ZERO,FILL
2086		- FDB SEMIS
2087		-*
2088		-* ======>> 135 <<
2089		- FCB $86
2090		- FCC 'BLANK' ; 'BLANKS'
2091		- FCB $D3
2092		- FDB ERASE-8
2093		-BLANKS FDB DOCOL,BL,FILL
2094		- FDB SEMIS
2095		-*
2096		-* ======>> 136 <<
2097		- FCB $84
2098		- FCC 'HOL' ; 'HOLD'
2099		- FCB $C4
2100		- FDB BLANKS-9
2101		-HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
2102		- FDB SEMIS
2103		-*
2104		-* ======>> 137 <<
2105		- FCB $83
2106		- FCC 'PA' ; 'PAD'
2107		- FCB $C4
2108		- FDB HOLD-7
2109		-PAD FDB DOCOL,HERE,CLITER
2110		- FCB $44
2111		- FDB PLUS
2112		- FDB SEMIS
2113		-*
2114		-* ######>> screen 48 <<
2115		-* ======>> 138 <<
2116		- FCB $84
2117		- FCC 'WOR' ; 'WORD'
2118		- FCB $C4
2119		- FDB PAD-6
2120		-WORD FDB DOCOL,BLK,AT,ZBRAN
2121		- FDB WORD2-*
2122		- FDB BLK,AT,BLOCK,BRAN
2123		- FDB WORD3-*
2124		-WORD2 FDB TIB,AT
2125		-WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,CLITER
2126		- FCB 34
2127		- FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
2128		- FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
2129		- FDB SEMIS
2130		-*
2131		-* ######>> screen 49 <<
2132		-* ======>> 139 <<
2133		- FCB $88
2134		- FCC '(NUMBER' ; '(NUMBER)'
2135		- FCB $A9
2136		- FDB WORD-7
2137		-PNUMB FDB DOCOL
2138		-PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
2139		- FDB PNUMB4-*
2140		- FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
2141		- FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
2142		- FDB PNUMB3-*
2143		- FDB ONE,DPL,PSTORE
2144		-PNUMB3 FDB FROMR,BRAN
2145		- FDB PNUMB2-*
2146		-PNUMB4 FDB FROMR
2147		- FDB SEMIS
2148		-*
2149		-* ======>> 140 <<
2150		- FCB $86
2151		- FCC 'NUMBE' ; 'NUMBER'
2152		- FCB $D2
2153		- FDB PNUMB-11
2154		-NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,CLITER
2155		- FCC "-" minus sign
2156		- FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
2157		-NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
2158		- FDB ZBRAN
2159		- FDB NUMB2-*
2160		- FDB DUP,CAT,CLITER
2161		- FCC "."
2162		- FDB SUB,ZERO,QERR,ZERO,BRAN
2163		- FDB NUMB1-*
2164		-NUMB2 FDB DROP,FROMR,ZBRAN
2165		- FDB NUMB3-*
2166		- FDB DMINUS
2167		-NUMB3 FDB SEMIS
2168		-*
2169		-* ======>> 141 <<
2170		- FCB $85
2171		- FCC '-FIN' ; '-FIND'
2172		- FCB $C4
2173		- FDB NUMB-9
2174		-DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
2175		- FDB PFIND,DUP,ZEQU,ZBRAN
2176		- FDB DFIND2-*
2177		- FDB DROP,HERE,LATEST,PFIND
2178		-DFIND2 FDB SEMIS
2179		-*
2180		-* ######>> screen 50 <<
2181		-* ======>> 142 <<
2182		- FCB $87
2183		- FCC '(ABORT' ; '(ABORT)'
2184		- FCB $A9
2185		- FDB DFIND-8
2186		-PABORT FDB DOCOL,ABORT
2187		- FDB SEMIS
2188		-*
2189		-* ======>> 143 <<
2190		- FCB $85
2191		- FCC 'ERRO' ; 'ERROR'
2192		- FCB $D2
2193		- FDB PABORT-10
2194		-ERROR FDB DOCOL,WARN,AT,ZLESS
2195		- FDB ZBRAN
2196		-* note: WARNING is -1 to abort, 0 to print error #
2197		-* and 1 to print error message from disc
2198		- FDB ERROR2-*
2199		- FDB PABORT
2200		-ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
2201		- FCB 4,7 ( bell )
2202		- FCC " ? "
2203		- FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
2204		- FDB SEMIS
2205		-*
2206		-* ======>> 144 <<
2207		- FCB $83
2208		- FCC 'ID' ; 'ID.'
2209		- FCB $AE
2210		- FDB ERROR-8
2211		-IDDOT FDB DOCOL,PAD,CLITER
2212		- FCB 32
2213		- FDB CLITER
2214		- FCB $5F ( underline )
2215		- FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
2216		- FDB SWAP,CMOVE,PAD,COUNT,CLITER
2217		- FCB 31
2218		- FDB AND,TYPE,SPACE
2219		- FDB SEMIS
2220		-*
2221		-* ######>> screen 51 <<
2222		-* ======>> 145 <<
2223		- FCB $86
2224		- FCC 'CREAT' ; 'CREATE'
2225		- FCB $C5
2226		- FDB IDDOT-6
2227		-CREATE FDB DOCOL,DFIND,ZBRAN
2228		- FDB CREAT2-*
2229		- FDB DROP,PDOTQ
2230		- FCB 8
2231		- FCB 7 ( bel )
2232		- FCC "redef: "
2233		- FDB NFA,IDDOT,CLITER
2234		- FCB 4
2235		- FDB MESS,SPACE
2236		-CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
2237		- FDB ONEP,ALLOT,DUP,CLITER
2238		- FCB $A0
2239		- FDB TOGGLE,HERE,ONE,SUB,CLITER
2240		- FCB $80
2241		- FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
2242		- FDB HERE,TWOP,COMMA
2243		- FDB SEMIS
2244		-*
2245		-* ######>> screen 52 <<
2246		-* ======>> 146 <<
2247		- FCB $C9 immediate
2248		- FCC '[COMPILE' ; '[COMPILE]'
2249		- FCB $DD
2250		- FDB CREATE-9
2251		-BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
2252		- FDB SEMIS
2253		-*
2254		-* ======>> 147 <<
2255		- FCB $C7 immediate
2256		- FCC 'LITERA' ; 'LITERAL'
2257		- FCB $CC
2258		- FDB BCOMP-12
2259		-LITER FDB DOCOL,STATE,AT,ZBRAN
2260		- FDB LITER2-*
2261		- FDB COMPIL,LIT,COMMA
2262		-LITER2 FDB SEMIS
2263		-*
2264		-* ======>> 148 <<
2265		- FCB $C8 immediate
2266		- FCC 'DLITERA' ; 'DLITERAL'
2267		- FCB $CC
2268		- FDB LITER-10
2269		-DLITER FDB DOCOL,STATE,AT,ZBRAN
2270		- FDB DLITE2-*
2271		- FDB SWAP,LITER,LITER
2272		-DLITE2 FDB SEMIS
2273		-*
2274		-* ######>> screen 53 <<
2275		-* ======>> 149 <<
2276		- FCB $89
2277		- FCC 'INTERPRE' ; 'INTERPRET'
2278		- FCB $D4
2279		- FDB DLITER-11
2280		-INTERP FDB DOCOL
2281		-INTER2 FDB DFIND,ZBRAN
2282		- FDB INTER5-*
2283		- FDB STATE,AT,LESS
2284		- FDB ZBRAN
2285		- FDB INTER3-*
2286		- FDB CFA,COMMA,BRAN
2287		- FDB INTER4-*
2288		-INTER3 FDB CFA,EXEC
2289		-INTER4 FDB BRAN
2290		- FDB INTER7-*
2291		-INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
2292		- FDB INTER6-*
2293		- FDB DLITER,BRAN
2294		- FDB INTER7-*
2295		-INTER6 FDB DROP,LITER
2296		-INTER7 FDB QSTACK,BRAN
2297		- FDB INTER2-*
2298		-* FDB SEMIS never executed
2299		-
2300		-*
2301		-* ######>> screen 54 <<
2302		-* ======>> 150 <<
2303		- FCB $89
2304		- FCC 'IMMEDIAT' ; 'IMMEDIATE'
2305		- FCB $C5
2306		- FDB INTERP-12
2307		-IMMED FDB DOCOL,LATEST,CLITER
2308		- FCB $40
2309		- FDB TOGGLE
2310		- FDB SEMIS
2311		-*
2312		-* ======>> 151 <<
2313		- FCB $8A
2314		- FCC 'VOCABULAR' ; 'VOCABULARY'
2315		- FCB $D9
2316		- FDB IMMED-12
2317		-VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
2318		- FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
2319		-DOVOC FDB TWOP,CONTXT,STORE
2320		- FDB SEMIS
2321		-*
2322		-* ======>> 152 <<
2323		-*
2324		-* Note: FORTH does not go here in the rom-able dictionary,
2325		-* since FORTH is a type of variable.
2326		-*
2327		-*
2328		-* ======>> 153 <<
2329		- FCB $8B
2330		- FCC 'DEFINITION' ; 'DEFINITIONS'
2331		- FCB $D3
2332		- FDB VOCAB-13
2333		-DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
2334		- FDB SEMIS
2335		-*
2336		-* ======>> 154 <<
2337		- FCB $C1 immediate (
2338		- FCB $A8
2339		- FDB DEFIN-14
2340		-PAREN FDB DOCOL,CLITER
2341		- FCC ")"
2342		- FDB WORD
2343		- FDB SEMIS
2344		-*
2345		-* ######>> screen 55 <<
2346		-* ======>> 155 <<
2347		- FCB $84
2348		- FCC 'QUI' ; 'QUIT'
2349		- FCB $D4
2350		- FDB PAREN-4
2351		-QUIT FDB DOCOL,ZERO,BLK,STORE
2352		- FDB LBRAK
2353		-*
2354		-* Here is the outer interpretter
2355		-* which gets a line of input, does it, prints " OK"
2356		-* then repeats :
2357		-QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
2358		- FDB ZBRAN
2359		- FDB QUIT3-*
2360		- FDB PDOTQ
2361		- FCB 3
2362		- FCC ' OK' ; ' OK'
2363		-QUIT3 FDB BRAN
2364		- FDB QUIT2-*
2365		-* FDB SEMIS ( never executed )
2366		-*
2367		-* ======>> 156 <<
2368		- FCB $85
2369		- FCC 'ABOR' ; 'ABORT'
2370		- FCB $D4
2371		- FDB QUIT-7
2372		-ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
2373		- FCB 8
2374		- FCC "Forth-68"
2375		- FDB FORTH,DEFIN
2376		- FDB QUIT
2377		-* FDB SEMIS never executed
2378		- PAGE
2379		-*
2380		-* ######>> screen 56 <<
2381		-* bootstrap code... moves rom contents to ram :
2382		-* ======>> 157 <<
2383		- FCB $84
2384		- FCC 'COL' ; 'COLD'
2385		- FCB $C4
2386		- FDB ABORT-8
2387		-COLD FDB *+2
2388		-CENT LDS #REND-1 top of destination
2389		- LDX #ERAM top of stuff to move
2390		-COLD2 LEAX -1,X ;
2391		- LDA 0,X
2392		- PSHS A ; move TASK & FORTH to ram
2393		- CMPX #RAM
2394		- BNE COLD2
2395		-*
2396		- LDS #XFENCE-1 put stack at a safe place for now
2397		- LDX COLINT
2398		- STX XCOLUM
2399		- LDX DELINT
2400		- STX XDELAY
2401		- LDX VOCINT
2402		- STX XVOCL
2403		- LDX DPINIT
2404		- STX XDP
2405		- LDX FENCIN
2406		- STX XFENCE
2407		-
2408		-
2409		-WENT LDS #XFENCE-1 top of destination
2410		- LDX #FENCIN top of stuff to move
2411		-WARM2 LEAX -1,X ;
2412		- LDA 0,X
2413		- PSHS A ;
2414		- CMPX #SINIT
2415		- BNE WARM2
2416		-*
2417		- LDS SINIT
2418		- LDX UPINIT
2419		- STX UP init user ram pointer
2420		- LDX #ABORT
2421		- STX IP
2422		- NOP Here is a place to jump to special user
2423		- NOP initializations such as I/0 interrups
2424		- NOP
2425		-*
2426		-* For systems with TRACE:
2427		- LDX #00
2428		- STX TRLIM clear trace mode
2429		- LDX #0
2430		- STX BRKPT clear breakpoint address
2431		- JMP RPSTOR+2 start the virtual machine running !
2432		-*
2433		-* Here is the stuff that gets copied to ram :
2434		-* at address $140:
2435		-*
2436		-RAM FDB $3000,$3000,0,0
2437		-
2438		-* ======>> (152) <<
2439		- FCB $C5 immediate
2440		- FCC 'FORT' ; 'FORTH'
2441		- FCB $C8
2442		- FDB NOOP-7
2443		-RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
2444		- FDB 0
2445		- FCC "(C) Forth Interest Group, 1979"
2446		- FCB $84
2447		- FCC 'TAS' ; 'TASK'
2448		- FCB $CB
2449		- FDB FORTH-8
2450		-RTASK FDB DOCOL,SEMIS
2451		-ERAM FCC "David Lion"
2452		- PAGE
2453		-*
2454		-* ######>> screen 57 <<
2455		-* ======>> 158 <<
2456		- FCB $84
2457		- FCC 'S->' ; 'S->D'
2458		- FCB $C4
2459		- FDB COLD-7
2460		-STOD FDB DOCOL,DUP,ZLESS,MINUS
2461		- FDB SEMIS
2462		-
2463		-
2464		-*
2465		-* ======>> 159 <<
2466		- FCB $81 ; *
2467		- FCB $AA
2468		- FDB STOD-7
2469		-STAR FDB *+2
2470		- JSR USTARS
2471		- LEAS 1,S ;
2472		- LEAS 1,S ;
2473		- JMP NEXT
2474		-*
2475		-* ======>> 160 <<
2476		- FCB $84
2477		- FCC '/MO' ; '/MOD'
2478		- FCB $C4
2479		- FDB STAR-4
2480		-SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
2481		- FDB SEMIS
2482		-*
2483		-* ======>> 161 <<
2484		- FCB $81 ; /
2485		- FCB $AF
2486		- FDB SLMOD-7
2487		-SLASH FDB DOCOL,SLMOD,SWAP,DROP
2488		- FDB SEMIS
2489		-*
2490		-* ======>> 162 <<
2491		- FCB $83
2492		- FCC 'MO' ; 'MOD'
2493		- FCB $C4
2494		- FDB SLASH-4
2495		-MOD FDB DOCOL,SLMOD,DROP
2496		- FDB SEMIS
2497		-*
2498		-* ======>> 163 <<
2499		- FCB $85
2500		- FCC '/MO' ; '/MOD'
2501		- FCB $C4
2502		- FDB MOD-6
2503		-SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
2504		- FDB SEMIS
2505		-*
2506		-* ======>> 164 <<
2507		- FCB $82
2508		- FCC '' ; '/'
2509		- FCB $AF
2510		- FDB SSMOD-8
2511		-SSLASH FDB DOCOL,SSMOD,SWAP,DROP
2512		- FDB SEMIS
2513		-*
2514		-* ======>> 165 <<
2515		- FCB $85
2516		- FCC 'M/MO' ; 'M/MOD'
2517		- FCB $C4
2518		- FDB SSLASH-5
2519		-MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
2520		- FDB FROMR,SWAP,TOR,USLASH,FROMR
2521		- FDB SEMIS
2522		-*
2523		-* ======>> 166 <<
2524		- FCB $83
2525		- FCC 'AB' ; 'ABS'
2526		- FCB $D3
2527		- FDB MSMOD-8
2528		-ABS FDB DOCOL,DUP,ZLESS,ZBRAN
2529		- FDB ABS2-*
2530		- FDB MINUS
2531		-ABS2 FDB SEMIS
2532		-*
2533		-* ======>> 167 <<
2534		- FCB $84
2535		- FCC 'DAB' ; 'DABS'
2536		- FCB $D3
2537		- FDB ABS-6
2538		-DABS FDB DOCOL,DUP,ZLESS,ZBRAN
2539		- FDB DABS2-*
2540		- FDB DMINUS
2541		-DABS2 FDB SEMIS
2542		-*
2543		-* ######>> screen 58 <<
2544		-* Disc primatives :
2545		-* ======>> 168 <<
2546		- FCB $83
2547		- FCC 'US' ; 'USE'
2548		- FCB $C5
2549		- FDB DABS-7
2550		-USE FDB DOCON
2551		- FDB XUSE
2552		-* ======>> 169 <<
2553		- FCB $84
2554		- FCC 'PRE' ; 'PREV'
2555		- FCB $D6
2556		- FDB USE-6
2557		-PREV FDB DOCON
2558		- FDB XPREV
2559		-* ======>> 170 <<
2560		- FCB $84
2561		- FCC '+BU' ; '+BUF'
2562		- FCB $C6
2563		- FDB PREV-7
2564		-PBUF FDB DOCOL,CLITER
2565		- FCB $84
2566		- FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
2567		- FDB PBUF2-*
2568		- FDB DROP,FIRST
2569		-PBUF2 FDB DUP,PREV,AT,SUB
2570		- FDB SEMIS
2571		-*
2572		-* ======>> 171 <<
2573		- FCB $86
2574		- FCC 'UPDAT' ; 'UPDATE'
2575		- FCB $C5
2576		- FDB PBUF-7
2577		-UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
2578		- FDB SEMIS
2579		-*
2580		-* ======>> 172 <<
2581		- FCB $8D
2582		- FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
2583		- FCB $D3
2584		- FDB UPDATE-9
2585		-MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
2586		- FDB SEMIS
2587		-*
2588		-* ======>> 173 <<
2589		- FCB $83
2590		- FCC 'DR' ; 'DR0'
2591		- FCB $B0
2592		- FDB MTBUF-16
2593		-DRZERO FDB DOCOL,ZERO,OFSET,STORE
2594		- FDB SEMIS
2595		-*
2596		-* ======>> 174 <<== system dependant word
2597		- FCB $83
2598		- FCC 'DR' ; 'DR1'
2599		- FCB $B1
2600		- FDB DRZERO-6
2601		-DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
2602		- FDB SEMIS
2603		-*
2604		-* ######>> screen 59 <<
2605		-* ======>> 175 <<
2606		- FCB $86
2607		- FCC 'BUFFE' ; 'BUFFER'
2608		- FCB $D2
2609		- FDB DRONE-6
2610		-BUFFER FDB DOCOL,USE,AT,DUP,TOR
2611		-BUFFR2 FDB PBUF,ZBRAN
2612		- FDB BUFFR2-*
2613		- FDB USE,STORE,R,AT,ZLESS
2614		- FDB ZBRAN
2615		- FDB BUFFR3-*
2616		- FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
2617		-BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
2618		- FDB SEMIS
2619		-*
2620		-* ######>> screen 60 <<
2621		-* ======>> 176 <<
2622		- FCB $85
2623		- FCC 'BLOC' ; 'BLOCK'
2624		- FCB $CB
2625		- FDB BUFFER-9
2626		-BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
2627		- FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
2628		- FDB BLOCK5-*
2629		-BLOCK3 FDB PBUF,ZEQU,ZBRAN
2630		- FDB BLOCK4-*
2631		- FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
2632		-BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
2633		- FDB BLOCK3-*
2634		- FDB DUP,PREV,STORE
2635		-BLOCK5 FDB FROMR,DROP,TWOP
2636		- FDB SEMIS
2637		-*
2638		-* ######>> screen 61 <<
2639		-* ======>> 177 <<
2640		- FCB $86
2641		- FCC '(LINE' ; '(LINE)'
2642		- FCB $A9
2643		- FDB BLOCK-8
2644		-PLINE FDB DOCOL,TOR,CLITER
2645		- FCB $40
2646		- FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,CLITER
2647		- FCB $40
2648		- FDB SEMIS
2649		-*
2650		-* ======>> 178 <<
2651		- FCB $85
2652		- FCC '.LIN' ; '.LINE'
2653		- FCB $C5
2654		- FDB PLINE-9
2655		-DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
2656		- FDB SEMIS
2657		-*
2658		-* ======>> 179 <<
2659		- FCB $87
2660		- FCC 'MESSAG' ; 'MESSAGE'
2661		- FCB $C5
2662		- FDB DLINE-8
2663		-MESS FDB DOCOL,WARN,AT,ZBRAN
2664		- FDB MESS3-*
2665		- FDB DDUP,ZBRAN
2666		- FDB MESS3-*
2667		- FDB CLITER
2668		- FCB 4
2669		- FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
2670		- FDB MESS4-*
2671		-MESS3 FDB PDOTQ
2672		- FCB 6
2673		- FCC 'err # ' ; 'err # '
2674		- FDB DOT
2675		-MESS4 FDB SEMIS
2676		-*
2677		-* ======>> 180 <<
2678		- FCB $84
2679		- FCC 'LOA' ; 'LOAD' : input:scr #
2680		- FCB $C4
2681		- FDB MESS-10
2682		-LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
2683		- FDB BSCR,STAR,BLK,STORE
2684		- FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
2685		- FDB SEMIS
2686		-*
2687		-* ======>> 181 <<
2688		- FCB $C3
2689		- FCC '--' ; '-->'
2690		- FCB $BE
2691		- FDB LOAD-7
2692		-ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
2693		- FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
2694		- FDB SEMIS
2695		- PAGE
2696		-*
2697		-*
2698		-* ######>> screen 63 <<
2699		-* The next 4 subroutines are machine dependent, and are
2700		-* called by words 13 through 16 in the dictionary.
2701		-*
2702		-* ======>> 182 << code for EMIT
2703		-PEMIT STB N save B
2704		- STX N+1 save X
2705		- LDB ACIAC
2706		- BITB #2 check ready bit
2707		- BEQ PEMIT+4 if not ready for more data
2708		- STA ACIAD
2709		- LDX UP
2710		- STB IOSTAT-UORIG,X
2711		- LDB N recover B & X
2712		- LDX N+1
2713		- RTS only A register may change
2714		-* PEMIT JMP $E1D1 for MIKBUG
2715		-* PEMIT FCB $3F,$11,$39 for PROTO
2716		-* PEMIT JMP $D286 for Smoke Signal DOS
2717		-*
2718		-* ======>> 183 << code for KEY
2719		-PKEY STB N
2720		- STX N+1
2721		- LDB ACIAC
2722		- ASRB ;
2723		- BCC PKEY+4 no incoming data yet
2724		- LDA ACIAD
2725		- ANDA #$7F strip parity bit
2726		- LDX UP
2727		- STB IOSTAT+1-UORIG,X
2728		- LDB N
2729		- LDX N+1
2730		- RTS
2731		-* PKEY JMP $E1AC for MIKBUG
2732		-* PKEY FCB $3F,$14,$39 for PROTO
2733		-* PKEY JMP $D289 for Smoke Signal DOS
2734		-*
2735		-* ######>> screen 64 <<
2736		-* ======>> 184 << code for ?TERMINAL
2737		-PQTER LDA ACIAC Test for 'break' condition
2738		- ANDA #$11 mask framing error bit and
2739		-* input buffer full
2740		- BEQ PQTER2
2741		- LDA ACIAD clear input buffer
2742		- LDA #01
2743		-PQTER2 RTS
2744		-
2745		-
2746		- PAGE
2747		-*
2748		-* ======>> 185 << code for CR
2749		-PCR LDA #$D carriage return
2750		- BSR PEMIT
2751		- LDA #$A line feed
2752		- BSR PEMIT
2753		- LDA #$7F rubout
2754		- LDX UP
2755		- LDB XDELAY+1-UORIG,X
2756		-PCR2 DECB ;
2757		- BMI PQTER2 return if minus
2758		- PSHS B ; save counter
2759		- BSR PEMIT print RUBOUTs to delay.....
2760		- PULS B ;
2761		- BRA PCR2 repeat
2762		-
2763		-
2764		- PAGE
2765		-*
2766		-* ######>> screen 66 <<
2767		-* ======>> 187 <<
2768		- FCB $85
2769		- FCC '?DIS' ; '?DISC'
2770		- FCB $C3
2771		- FDB ARROW-6
2772		-QDISC FDB *+2
2773		- JMP NEXT
2774		-*
2775		-* ######>> screen 67 <<
2776		-* ======>> 189 <<
2777		- FCB $8B
2778		- FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
2779		- FCB $C5
2780		- FDB QDISC-8
2781		-BWRITE FDB *+2
2782		- JMP NEXT
2783		-*
2784		-* ######>> screen 68 <<
2785		-* ======>> 190 <<
2786		- FCB $8A
2787		- FCC 'BLOCK-REA' ; 'BLOCK-READ'
2788		- FCB $C4
2789		- FDB BWRITE-14
2790		-BREAD FDB *+2
2791		- JMP NEXT
2792		-*
2793		-*The next 3 words are written to create a substitute for disc
2794		-* mass memory,located between $3210 & $3FFF in ram.
2795		-* ======>> 190.1 <<
2796		- FCB $82
2797		- FCC 'L' ; 'LO'
2798		- FCB $CF
2799		- FDB BREAD-13
2800		-LO FDB DOCON
2801		- FDB MEMEND a system dependent equate at front
2802		-*
2803		-* ======>> 190.2 <<
2804		- FCB $82
2805		- FCC 'H' ; 'HI'
2806		- FCB $C9
2807		- FDB LO-5
2808		-HI FDB DOCON
2809		- FDB MEMTOP ( $3FFF in this version )
2810		-*
2811		-* ######>> screen 69 <<
2812		-* ======>> 191 <<
2813		- FCB $83
2814		- FCC 'R/' ; 'R/W'
2815		- FCB $D7
2816		- FDB HI-5
2817		-RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
2818		- FDB RW2-*
2819		- FDB PDOTQ
2820		- FCB 8
2821		- FCC ' Range ?' ; ' Range ?'
2822		- FDB QUIT
2823		-RW2 FDB FROMR,ZBRAN
2824		- FDB RW3-*
2825		- FDB SWAP
2826		-RW3 FDB BBUF,CMOVE
2827		- FDB SEMIS
2828		-*
2829		-* ######>> screen 72 <<
2830		-* ======>> 192 <<
2831		- FCB $C1 immediate
2832		- FCB $A7 ' ( tick )
2833		- FDB RW-6
2834		-TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
2835		- FDB SEMIS
2836		-*
2837		-* ======>> 193 <<
2838		- FCB $86
2839		- FCC 'FORGE' ; 'FORGET'
2840		- FCB $D4
2841		- FDB TICK-4
2842		-FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,CLITER
2843		- FCB $18
2844		- FDB QERR,TICK,DUP,FENCE,AT,LESS,CLITER
2845		- FCB $15
2846		- FDB QERR,DUP,ZERO,PORIG,GREAT,CLITER
2847		- FCB $15
2848		- FDB QERR,DUP,NFA,DP,STORE,LFA,AT,CONTXT,AT,STORE
2849		- FDB SEMIS
2850		-*
2851		-* ######>> screen 73 <<
2852		-* ======>> 194 <<
2853		- FCB $84
2854		- FCC 'BAC' ; 'BACK'
2855		- FCB $CB
2856		- FDB FORGET-9
2857		-BACK FDB DOCOL,HERE,SUB,COMMA
2858		- FDB SEMIS
2859		-*
2860		-* ======>> 195 <<
2861		- FCB $C5
2862		- FCC 'BEGI' ; 'BEGIN'
2863		- FCB $CE
2864		- FDB BACK-7
2865		-BEGIN FDB DOCOL,QCOMP,HERE,ONE
2866		- FDB SEMIS
2867		-*
2868		-* ======>> 196 <<
2869		- FCB $C5
2870		- FCC 'ENDI' ; 'ENDIF'
2871		- FCB $C6
2872		- FDB BEGIN-8
2873		-ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE
2874		- FDB OVER,SUB,SWAP,STORE
2875		- FDB SEMIS
2876		-*
2877		-* ======>> 197 <<
2878		- FCB $C4
2879		- FCC 'THE' ; 'THEN'
2880		- FCB $CE
2881		- FDB ENDIF-8
2882		-THEN FDB DOCOL,ENDIF
2883		- FDB SEMIS
2884		-*
2885		-* ======>> 198 <<
2886		- FCB $C2
2887		- FCC 'D' ; 'DO'
2888		- FCB $CF
2889		- FDB THEN-7
2890		-DO FDB DOCOL,COMPIL,XDO,HERE,THREE
2891		- FDB SEMIS
2892		-*
2893		-* ======>> 199 <<
2894		- FCB $C4
2895		- FCC 'LOO' ; 'LOOP'
2896		- FCB $D0
2897		- FDB DO-5
2898		-LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK
2899		- FDB SEMIS
2900		-*
2901		-* ======>> 200 <<
2902		- FCB $C5
2903		- FCC '+LOO' ; '+LOOP'
2904		- FCB $D0
2905		- FDB LOOP-7
2906		-PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK
2907		- FDB SEMIS
2908		-*
2909		-* ======>> 201 <<
2910		- FCB $C5
2911		- FCC 'UNTI' ; 'UNTIL' : ( same as END )
2912		- FCB $CC
2913		- FDB PLOOP-8
2914		-UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK
2915		- FDB SEMIS
2916		-*
2917		-* ######>> screen 74 <<
2918		-* ======>> 202 <<
2919		- FCB $C3
2920		- FCC 'EN' ; 'END'
2921		- FCB $C4
2922		- FDB UNTIL-8
2923		-END FDB DOCOL,UNTIL
2924		- FDB SEMIS
2925		-*
2926		-* ======>> 203 <<
2927		- FCB $C5
2928		- FCC 'AGAI' ; 'AGAIN'
2929		- FCB $CE
2930		- FDB END-6
2931		-AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK
2932		- FDB SEMIS
2933		-*
2934		-* ======>> 204 <<
2935		- FCB $C6
2936		- FCC 'REPEA' ; 'REPEAT'
2937		- FCB $D4
2938		- FDB AGAIN-8
2939		-REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR
2940		- FDB TWO,SUB,ENDIF
2941		- FDB SEMIS
2942		-*
2943		-* ======>> 205 <<
2944		- FCB $C2
2945		- FCC 'I' ; 'IF'
2946		- FCB $C6
2947		- FDB REPEAT-9
2948		-IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO
2949		- FDB SEMIS
2950		-*
2951		-* ======>> 206 <<
2952		- FCB $C4
2953		- FCC 'ELS' ; 'ELSE'
2954		- FCB $C5
2955		- FDB IF-5
2956		-ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
2957		- FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO
2958		- FDB SEMIS
2959		-*
2960		-* ======>> 207 <<
2961		- FCB $C5
2962		- FCC 'WHIL' ; 'WHILE'
2963		- FCB $C5
2964		- FDB ELSE-7
2965		-WHILE FDB DOCOL,IF,TWOP
2966		- FDB SEMIS
2967		-*
2968		-* ######>> screen 75 <<
2969		-* ======>> 208 <<
2970		- FCB $86
2971		- FCC 'SPACE' ; 'SPACES'
2972		- FCB $D3
2973		- FDB WHILE-8
2974		-SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
2975		- FDB SPACE3-*
2976		- FDB ZERO,XDO
2977		-SPACE2 FDB SPACE,XLOOP
2978		- FDB SPACE2-*
2979		-SPACE3 FDB SEMIS
2980		-*
2981		-* ======>> 209 <<
2982		- FCB $82
2983		- FCC '<' ; '<#'
2984		- FCB $A3
2985		- FDB SPACES-9
2986		-BDIGS FDB DOCOL,PAD,HLD,STORE
2987		- FDB SEMIS
2988		-*
2989		-* ======>> 210 <<
2990		- FCB $82
2991		- FCC '#' ; '#>'
2992		- FCB $BE
2993		- FDB BDIGS-5
2994		-EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
2995		- FDB SEMIS
2996		-*
2997		-* ======>> 211 <<
2998		- FCB $84
2999		- FCC 'SIG' ; 'SIGN'
3000		- FCB $CE
3001		- FDB EDIGS-5
3002		-SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
3003		- FDB SIGN2-*
3004		- FDB CLITER
3005		- FCC "-"
3006		- FDB HOLD
3007		-SIGN2 FDB SEMIS
3008		-*
3009		-* ======>> 212 <<
3010		- FCB $81 #
3011		- FCB $A3
3012		- FDB SIGN-7
3013		-DIG FDB DOCOL,BASE,AT,MSMOD,ROT,CLITER
3014		- FCB 9
3015		- FDB OVER,LESS,ZBRAN
3016		- FDB DIG2-*
3017		- FDB CLITER
3018		- FCB 7
3019		- FDB PLUS
3020		-DIG2 FDB CLITER
3021		- FCC "0" ascii zero
3022		- FDB PLUS,HOLD
3023		- FDB SEMIS
3024		-*
3025		-* ======>> 213 <<
3026		- FCB $82
3027		- FCC '#' ; '#S'
3028		- FCB $D3
3029		- FDB DIG-4
3030		-DIGS FDB DOCOL
3031		-DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
3032		- FDB DIGS2-*
3033		- FDB SEMIS
3034		-*
3035		-* ######>> screen 76 <<
3036		-* ======>> 214 <<
3037		- FCB $82
3038		- FCC '.' ; '.R'
3039		- FCB $D2
3040		- FDB DIGS-5
3041		-DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
3042		- FDB SEMIS
3043		-*
3044		-* ======>> 215 <<
3045		- FCB $83
3046		- FCC 'D.' ; 'D.R'
3047		- FCB $D2
3048		- FDB DOTR-5
3049		-DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
3050		- FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
3051		- FDB SEMIS
3052		-*
3053		-* ======>> 216 <<
3054		- FCB $82
3055		- FCC 'D' ; 'D.'
3056		- FCB $AE
3057		- FDB DDOTR-6
3058		-DDOT FDB DOCOL,ZERO,DDOTR,SPACE
3059		- FDB SEMIS
3060		-*
3061		-* ======>> 217 <<
3062		- FCB $81 .
3063		- FCB $AE
3064		- FDB DDOT-5
3065		-DOT FDB DOCOL,STOD,DDOT
3066		- FDB SEMIS
3067		-*
3068		-* ======>> 218 <<
3069		- FCB $81 ?
3070		- FCB $BF
3071		- FDB DOT-4
3072		-QUEST FDB DOCOL,AT,DOT
3073		- FDB SEMIS
3074		-*
3075		-* ######>> screen 77 <<
3076		-* ======>> 219 <<
3077		- FCB $84
3078		- FCC 'LIS' ; 'LIST'
3079		- FCB $D4
3080		- FDB QUEST-4
3081		-LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
3082		- FCB 6
3083		- FCC "SCR # "
3084		- FDB DOT,CLITER
3085		- FCB $10
3086		- FDB ZERO,XDO
3087		-LIST2 FDB CR,I,THREE
3088		- FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
3089		- FDB LIST2-*
3090		- FDB CR
3091		- FDB SEMIS
3092		-*
3093		-* ======>> 220 <<
3094		- FCB $85
3095		- FCC 'INDE' ; 'INDEX'
3096		- FCB $D8
3097		- FDB LIST-7
3098		-INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
3099		-INDEX2 FDB CR,I,THREE
3100		- FDB DOTR,SPACE,ZERO,I,DLINE
3101		- FDB QTERM,ZBRAN
3102		- FDB INDEX3-*
3103		- FDB LEAVE
3104		-INDEX3 FDB XLOOP
3105		- FDB INDEX2-*
3106		- FDB SEMIS
3107		-*
3108		-* ======>> 221 <<
3109		- FCB $85
3110		- FCC 'TRIA' ; 'TRIAD'
3111		- FCB $C4
3112		- FDB INDEX-8
3113		-TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
3114		- FDB THREE,OVER,PLUS,SWAP,XDO
3115		-TRIAD2 FDB CR,I
3116		- FDB LIST,QTERM,ZBRAN
3117		- FDB TRIAD3-*
3118		- FDB LEAVE
3119		-TRIAD3 FDB XLOOP
3120		- FDB TRIAD2-*
3121		- FDB CR,CLITER
3122		- FCB $0F
3123		- FDB MESS,CR
3124		- FDB SEMIS
3125		-*
3126		-* ######>> screen 78 <<
3127		-* ======>> 222 <<
3128		- FCB $85
3129		- FCC 'VLIS' ; 'VLIST'
3130		- FCB $D4
3131		- FDB TRIAD-8
3132		-VLIST FDB DOCOL,CLITER
3133		- FCB $80
3134		- FDB OUT,STORE,CONTXT,AT,AT
3135		-VLIST1 FDB OUT,AT,COLUMS,AT,CLITER
3136		- FCB 32
3137		- FDB SUB,GREAT,ZBRAN
3138		- FDB VLIST2-*
3139		- FDB CR,ZERO,OUT,STORE
3140		-VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
3141		- FDB DUP,ZEQU,QTERM,OR,ZBRAN
3142		- FDB VLIST1-*
3143		- FDB DROP
3144		- FDB SEMIS
3145		-*
3146		-* ======>> XX <<
3147		- FCB $84
3148		- FCC 'NOO' ; 'NOOP'
3149		- FCB $D0
3150		- FDB VLIST-8
3151		-NOOP FDB NEXT a useful no-op
3152		-ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
3153		-
3154		-
3155		-
3156		-
3157		-
3158		-
3159		-
3160		- PAGE
3161		- OPT L
3162		- END

Binary files /dev/null and b/junkpile/a.out differ

--- /dev/null

+++ b/junkpile/fig-forth-auto6809opt.list

		@@ -0,0 +1,5647 @@
	1	+ (fig-forth-auto680):00001 OPT PRT
	2	+ (fig-forth-auto680):00002
	3	+ (fig-forth-auto680):00003 * fig-FORTH FOR 6809
	4	+ (fig-forth-auto680):00004 * ASSEMBLY SOURCE LISTING
	5	+ (fig-forth-auto680):00005
	6	+ (fig-forth-auto680):00006 * RELEASE 0
	7	+ (fig-forth-auto680):00007 * JAN 2019
	8	+ (fig-forth-auto680):00008 * WITH COMPILER SECURITY
	9	+ (fig-forth-auto680):00009 * AND VARIABLE LENGTH NAMES
	10	+ (fig-forth-auto680):00010 *
	11	+ (fig-forth-auto680):00011 * Adapted by Joel Matthew Rees
	12	+ (fig-forth-auto680):00012 * from fig-FORTH for 6800 by Dave Lion, et. al.
	13	+ (fig-forth-auto680):00013
	14	+ (fig-forth-auto680):00014 * This free/libre/open source publication is provided
	15	+ (fig-forth-auto680):00015 * through the courtesy of:
	16	+ (fig-forth-auto680):00016 * FORTH
	17	+ (fig-forth-auto680):00017 * INTEREST
	18	+ (fig-forth-auto680):00018 * GROUP
	19	+ (fig-forth-auto680):00019 * fig
	20	+ (fig-forth-auto680):00020 * and other interested parties.
	21	+ (fig-forth-auto680):00021
	22	+ (fig-forth-auto680):00022 * Ancient address:
	23	+ (fig-forth-auto680):00023 * P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
	24	+ (fig-forth-auto680):00024 * URL: http://www.forth.org
	25	+ (fig-forth-auto680):00025 * Further distribution must include this notice.
	26	+ (fig-forth-auto680):00026 PAGE
	27	+ (fig-forth-auto680):00027 NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
	28	+ (fig-forth-auto680):00028 OPT NOG,PAG
	29	+ (fig-forth-auto680):00029 * filename fig-forth-auto6809opt.asm
	30	+ (fig-forth-auto680):00030 * === FORTH-6809 {date} {time}
	31	+ (fig-forth-auto680):00031
	32	+ (fig-forth-auto680):00032
	33	+ (fig-forth-auto680):00033 * Permission is hereby granted, free of charge, to any person obtaining a copy
	34	+ (fig-forth-auto680):00034 * of this software and associated documentation files (the "Software"), to deal
	35	+ (fig-forth-auto680):00035 * in the Software without restriction, including without limitation the rights
	36	+ (fig-forth-auto680):00036 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
	37	+ (fig-forth-auto680):00037 * copies of the Software, and to permit persons to whom the Software is
	38	+ (fig-forth-auto680):00038 * furnished to do so, subject to the following conditions:
	39	+ (fig-forth-auto680):00039 *
	40	+ (fig-forth-auto680):00040 * The above copyright notice and this permission notice shall be included in
	41	+ (fig-forth-auto680):00041 * all copies or substantial portions of the Software.
	42	+ (fig-forth-auto680):00042
	43	+ (fig-forth-auto680):00043 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
	44	+ (fig-forth-auto680):00044 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
	45	+ (fig-forth-auto680):00045 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
	46	+ (fig-forth-auto680):00046 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
	47	+ (fig-forth-auto680):00047 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
	48	+ (fig-forth-auto680):00048 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
	49	+ (fig-forth-auto680):00049 * THE SOFTWARE.
	50	+ (fig-forth-auto680):00050 *
	51	+ (fig-forth-auto680):00051 * "Associated documentation" for this declaration of license
	52	+ (fig-forth-auto680):00052 * shall be interpreted to include only the comments in this file,
	53	+ (fig-forth-auto680):00053 * or, if the code is split into multiple files,
	54	+ (fig-forth-auto680):00054 * all files containing the complete source.
	55	+ (fig-forth-auto680):00055 *
	56	+ (fig-forth-auto680):00056 * This is the MIT model license, as published by the Open Source Consortium,
	57	+ (fig-forth-auto680):00057 * with associated documentation defined.
	58	+ (fig-forth-auto680):00058 * It was chosen to reflect the spirit of the original
	59	+ (fig-forth-auto680):00059 * terms of use, which used archaic legal terminology.
	60	+ (fig-forth-auto680):00060 *
	61	+ (fig-forth-auto680):00061
	62	+ (fig-forth-auto680):00062 * Authors of the 6800 model:
	63	+ (fig-forth-auto680):00063 * === Primary: Dave Lion,
	64	+ (fig-forth-auto680):00064 * === with help from
	65	+ (fig-forth-auto680):00065 * === Bob Smith,
	66	+ (fig-forth-auto680):00066 * === LaFarr Stuart,
	67	+ (fig-forth-auto680):00067 * === The Forth Interest Group
	68	+ (fig-forth-auto680):00068 * === PO Box 1105
	69	+ (fig-forth-auto680):00069 * === San Carlos, CA 94070
	70	+ (fig-forth-auto680):00070 * === and
	71	+ (fig-forth-auto680):00071 * === Unbounded Computing
	72	+ (fig-forth-auto680):00072 * === 1134-K Aster Ave.
	73	+ (fig-forth-auto680):00073 * === Sunnyvale, CA 94086
	74	+ (fig-forth-auto680):00074 *
	75	+ 0002 (fig-forth-auto680):00075 NATWID EQU 2 ; bytes per natural integer/pointer
	76	+ (fig-forth-auto680):00076 * The original version was developed on an AMI EVK 300 PROTO
	77	+ (fig-forth-auto680):00077 * system using an ACIA for the I/O.
	78	+ (fig-forth-auto680):00078 * This version is developed targeting the Tandy Color Computer.
	79	+ (fig-forth-auto680):00079
	80	+ (fig-forth-auto680):00080 * All terminal 1/0
	81	+ (fig-forth-auto680):00081 * is done in three subroutines:
	82	+ (fig-forth-auto680):00082 * PEMIT ( word # 182 )
	83	+ (fig-forth-auto680):00083 * PKEY ( 183 )
	84	+ (fig-forth-auto680):00084 * PQTERM ( 184 )
	85	+ (fig-forth-auto680):00085 *
	86	+ (fig-forth-auto680):00086 * The FORTH words for disc related I/O follow the model
	87	+ (fig-forth-auto680):00087 * of the FORTH Interest Group, but have not yet been
	88	+ (fig-forth-auto680):00088 * tested using a real disc.
	89	+ (fig-forth-auto680):00089 *
	90	+ (fig-forth-auto680):00090 * Addresses in the 6800 implementation reflect the fact that,
	91	+ (fig-forth-auto680):00091 * on the development system, it was convenient to
	92	+ (fig-forth-auto680):00092 * write-protect memory at hex 1000, and leave the first
	93	+ (fig-forth-auto680):00093 * 4K bytes write-enabled. As a consequence, code from
	94	+ (fig-forth-auto680):00094 * location $1000 to lable ZZZZ could be put in ROM.
	95	+ (fig-forth-auto680):00095 * Minor deviations from the model were made in the
	96	+ (fig-forth-auto680):00096 * initialization and words ?STACK and FORGET
	97	+ (fig-forth-auto680):00097 * in order to do this.
	98	+ (fig-forth-auto680):00098 * Those deviations will be altered in this
	99	+ (fig-forth-auto680):00099 * implementation for the 6809 -- Color Computer.
	100	+ (fig-forth-auto680):00100 *
	101	+ (fig-forth-auto680):00101
	102	+ (fig-forth-auto680):00102 *
	103	+ 7FFF (fig-forth-auto680):00103 MEMT32 EQU $7FFF absolute end of all ram
	104	+ 3FFF (fig-forth-auto680):00104 MEMT16 EQU $3FFF
	105	+ 7FFF (fig-forth-auto680):00105 MEMTOP EQU MEMT32 ; tentative guess
	106	+ FBCE (fig-forth-auto680):00106 ACIAC EQU $FBCE the ACIA control address and
	107	+ FBCF (fig-forth-auto680):00107 ACIAD EQU ACIAC+1 data address for PROTO
	108	+ (fig-forth-auto680):00108 PAGE
	109	+ (fig-forth-auto680):00109 * MEMORY MAP for this 16K\|32K system:
	110	+ (fig-forth-auto680):00110 * ( delineated so that systems with 4k byte write-
	111	+ (fig-forth-auto680):00111 * protected segments can write protect FORTH )
	112	+ (fig-forth-auto680):00112 *
	113	+ (fig-forth-auto680):00113 * addr. contents pointer init by
	114	+ (fig-forth-auto680):00114 * ** *************************** *** ****
	115	+ (fig-forth-auto680):00115 * 2nd through 4th per-user tables
	116	+ (fig-forth-auto680):00116 * 4000\|7D00
	117	+ 0100 (fig-forth-auto680):00117 USERSZ EQU 256 ; (Addressable by DP)
	118	+ 0001 (fig-forth-auto680):00118 USER16 EQU 1 ; We can change these for ROMPACK or 64K.
	119	+ 0004 (fig-forth-auto680):00119 USER32 EQU 4
	120	+ 0004 (fig-forth-auto680):00120 USERCT EQU USER32
	121	+ 3F00 (fig-forth-auto680):00121 IUP16 EQU MEMT16+1-USER16*USERSZ
	122	+ 7C00 (fig-forth-auto680):00122 IUP32 EQU MEMT32+1-USER32*USERSZ
	123	+ 7C00 (fig-forth-auto680):00123 IUP EQU IUP32
	124	+ 007C (fig-forth-auto680):00124 IUPDP EQU IUP/256
	125	+ (fig-forth-auto680):00125 * user tables of variables
	126	+ (fig-forth-auto680):00126 * registers & pointers for the virtual machine
	127	+ (fig-forth-auto680):00127 * scratch area used by various words
	128	+ (fig-forth-auto680):00128 * 3F00\|7C00 <== UP (DICTPT)
	129	+ (fig-forth-auto680):00129 * 3EFF\|7BFF HI
	130	+ (fig-forth-auto680):00130 * substitute for disc mass memory
	131	+ 0003 (fig-forth-auto680):00131 RAMSCR EQU 3
	132	+ 0400 (fig-forth-auto680):00132 SCRSZ EQU 1024
	133	+ (fig-forth-auto680):00133 * 3300\|7000 LO,MEMEND
	134	+ 3300 (fig-forth-auto680):00134 RAMD16 EQU IUP16-RAMSCR*SCRSZ
	135	+ 7000 (fig-forth-auto680):00135 RAMD32 EQU IUP32-RAMSCR*SCRSZ
	136	+ 7000 (fig-forth-auto680):00136 RAMDSK EQU RAMD32
	137	+ 3300 (fig-forth-auto680):00137 MEME16 EQU RAMD16
	138	+ 7000 (fig-forth-auto680):00138 MEME32 EQU RAMD32
	139	+ 7000 (fig-forth-auto680):00139 MEMEND EQU MEME32
	140	+ (fig-forth-auto680):00140 * 32FF\|6FFF
	141	+ (fig-forth-auto680):00141 * 4 buffer sectors of VIRTUAL MEMORY
	142	+ 0004 (fig-forth-auto680):00142 NBLK EQU 4 ; # of disc buffer blocks for virtual memory
	143	+ (fig-forth-auto680):00143 * Should NBLK be SCRSZ/SECTSZ?
	144	+ (fig-forth-auto680):00144 * each block is SECTSZ+SECTRL bytes in size,
	145	+ (fig-forth-auto680):00145 * holding SECTSZ characters
	146	+ 0100 (fig-forth-auto680):00146 SECTSZ EQU 256
	147	+ 0008 (fig-forth-auto680):00147 SECTRL EQU 8
	148	+ 0420 (fig-forth-auto680):00148 BUFSZ EQU (SECTSZ+SECTRL)*NBLK
	149	+ (fig-forth-auto680):00149 * 2EE0\|6BE0 FIRST
	150	+ 2EE0 (fig-forth-auto680):00150 BUFB16 EQU MEME16-BUFSZ
	151	+ 6BE0 (fig-forth-auto680):00151 BUFB32 EQU MEME32-BUFSZ
	152	+ 6BE0 (fig-forth-auto680):00152 BUFBAS EQU BUFB32
	153	+ (fig-forth-auto680):00153 * "end" of "usable ram" -- in 16K
	154	+ (fig-forth-auto680):00154 * 2EE0\|6BE0 <== RP RINIT
	155	+ 2EE0 (fig-forth-auto680):00155 IRP16 EQU BUFB16
	156	+ 6BE0 (fig-forth-auto680):00156 IRP32 EQU BUFB32
	157	+ 6BE0 (fig-forth-auto680):00157 IRP EQU IRP32
	158	+ (fig-forth-auto680):00158 * RETURN STACK
	159	+ (fig-forth-auto680):00159 * (64\|112 levels nesting)
	160	+ 0080 (fig-forth-auto680):00160 RSTK16 EQU 128
	161	+ 00E0 (fig-forth-auto680):00161 RSTK32 EQU 224
	162	+ (fig-forth-auto680):00162 * (2E60\|6B00)
	163	+ 2E60 (fig-forth-auto680):00163 SFTB16 EQU IRP16-RSTK16
	164	+ 6B00 (fig-forth-auto680):00164 SFTB32 EQU IRP32-RSTK32
	165	+ 6B00 (fig-forth-auto680):00165 SFTBND EQU SFTB32
	166	+ (fig-forth-auto680):00166 * INPUT LINE BUFFER
	167	+ (fig-forth-auto680):00167 * holds up to 256 characters
	168	+ (fig-forth-auto680):00168 * and is scanned upward by IN
	169	+ (fig-forth-auto680):00169 * starting at TIB
	170	+ 0100 (fig-forth-auto680):00170 TIBSZ EQU 256
	171	+ (fig-forth-auto680):00171 * 2D60\|6A00
	172	+ 2D60 (fig-forth-auto680):00172 ITIB16 EQU SFTB16-TIBSZ
	173	+ 6A00 (fig-forth-auto680):00173 ITIB32 EQU SFTB32-TIBSZ
	174	+ 6A00 (fig-forth-auto680):00174 ITIB EQU ITIB32
	175	+ (fig-forth-auto680):00175 * 2D60\|6A00 <== IN TIB
	176	+ 2D60 (fig-forth-auto680):00176 ISP16 EQU ITIB16
	177	+ 6A00 (fig-forth-auto680):00177 ISP32 EQU ITIB32
	178	+ 6A00 (fig-forth-auto680):00178 ISP EQU ISP32
	179	+ (fig-forth-auto680):00179 * 2D60\|6A00 <== SP SP0,SINIT
	180	+ (fig-forth-auto680):00180 * DATA STACK
	181	+ (fig-forth-auto680):00181 * \| grows downward from 2A60\|6A00
	182	+ (fig-forth-auto680):00182 * v
	183	+ (fig-forth-auto680):00183 * - -
	184	+ (fig-forth-auto680):00184 * \|
	185	+ (fig-forth-auto680):00185 * I DICTIONARY grows upward
	186	+ (fig-forth-auto680):00186 *
	187	+ (fig-forth-auto680):00187 * ???? end of ram-dictionary. <== DICTPT DPINIT
	188	+ (fig-forth-auto680):00188 * "TASK"
	189	+ (fig-forth-auto680):00189 *
	190	+ (fig-forth-auto680):00190 * ???? "FORTH" ( a word ) <=, <== CONTEXT
	191	+ (fig-forth-auto680):00191 * `==== CURRENT
	192	+ (fig-forth-auto680):00192 * start of ram-dictionary.
	193	+ (fig-forth-auto680):00193 *
	194	+ (fig-forth-auto680):00194 * >>>>>> memory from here up must be in RAM area <<<<<<
	195	+ (fig-forth-auto680):00195 *
	196	+ (fig-forth-auto680):00196 * ????
	197	+ (fig-forth-auto680):00197 * 6k of romable "FORTH" <== IP ABORT
	198	+ (fig-forth-auto680):00198 * <== W
	199	+ (fig-forth-auto680):00199 * the VIRTUAL FORTH MACHINE
	200	+ (fig-forth-auto680):00200 *
	201	+ (fig-forth-auto680):00201 * 1208 initialization tables
	202	+ (fig-forth-auto680):00202 * 1204 <<< WARM START ENTRY >>>
	203	+ (fig-forth-auto680):00203 * 1200 <<< COLD START ENTRY >>>
	204	+ (fig-forth-auto680):00204 * 1200 lowest address used by FORTH
	205	+ (fig-forth-auto680):00205 *
	206	+ 1200 (fig-forth-auto680):00206 CODEBG EQU $1200
	207	+ (fig-forth-auto680):00207 * CODEBG EQU $3000
	208	+ (fig-forth-auto680):00208 *
	209	+ (fig-forth-auto680):00209 * >>>>>> memory from here down left alone <<<<<<
	210	+ (fig-forth-auto680):00210 * >>>>>> so we can safely call ROM routines <<<<<<
	211	+ (fig-forth-auto680):00211 *
	212	+ (fig-forth-auto680):00212 * 0000
	213	+ (fig-forth-auto680):00213 PAGE
	214	+ (fig-forth-auto680):00214 ***
	215	+ (fig-forth-auto680):00215 *
	216	+ (fig-forth-auto680):00216 * CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
	217	+ (fig-forth-auto680):00217 *
	218	+ (fig-forth-auto680):00218 * IP (hardware Y) points to the current instruction ( pre-increment mode )
	219	+ (fig-forth-auto680):00219 * RP (hardware S) points to last return address pushedin return stack
	220	+ (fig-forth-auto680):00220 * SP (hardware U) points to last byte pushed in data stack
	221	+ (fig-forth-auto680):00221 *
	222	+ (fig-forth-auto680):00222 * Y must be IP when NEXT is entered (if using the inner loop).
	223	+ (fig-forth-auto680):00223 *
	224	+ (fig-forth-auto680):00224 * When A and B hold one 16 bit FORTH data word,
	225	+ (fig-forth-auto680):00225 * A contains the high byte, B, the low byte.
	226	+ (fig-forth-auto680):00226 *
	227	+ (fig-forth-auto680):00227 * UP (hardware DP) is the base of per-task ("user") variables.
	228	+ (fig-forth-auto680):00228 * (Be careful of the stray semantics of "user".)
	229	+ (fig-forth-auto680):00229 *
	230	+ (fig-forth-auto680):00230 * W (hardware X) is the pointer to the "code field" address of native CPU
	231	+ (fig-forth-auto680):00231 * machine code to be executed for the definition of the dictionary word
	232	+ (fig-forth-auto680):00232 * to be executed/currently executing.
	233	+ (fig-forth-auto680):00233 * The following natural integer (word) begins any "parameter section"
	234	+ (fig-forth-auto680):00234 * (body) -- similar to a "this" pointer, but not the same.
	235	+ (fig-forth-auto680):00235 * It may be native CPU machine code, or it may be a global variable,
	236	+ (fig-forth-auto680):00236 * or it may be a list of Forth definition words (addresses).
	237	+ (fig-forth-auto680):00237 *
	238	+ (fig-forth-auto680):00238 * ======
	239	+ (fig-forth-auto680):00239 * This implementation uses the native subroutine architecture
	240	+ (fig-forth-auto680):00240 * rather than a postponed-push call that the 6800 model VM uses
	241	+ (fig-forth-auto680):00241 * to save code and time in leaf routines.
	242	+ (fig-forth-auto680):00242 *
	243	+ (fig-forth-auto680):00243 * This should allow directly calling many of the Forth words
	244	+ (fig-forth-auto680):00244 * from assembly language code.
	245	+ (fig-forth-auto680):00245 * (Be aware of the need for a valid W in some cases.)
	246	+ (fig-forth-auto680):00246 * It won't allow mixing assembly language directly into Forth word lists.
	247	+ (fig-forth-auto680):00247 * ======
	248	+ (fig-forth-auto680):00248 *
	249	+ (fig-forth-auto680):00249 * boolean flags:
	250	+ (fig-forth-auto680):00250 * 0 is false, anything else is true.
	251	+ (fig-forth-auto680):00251 * Most places in this model that set a boolean flag set true as 1.
	252	+ (fig-forth-auto680):00252 * This is in contrast to many models that set a boolean flag as -1.
	253	+ (fig-forth-auto680):00253 *
	254	+ (fig-forth-auto680):00254 ***
	255	+ (fig-forth-auto680):00255
	256	+ (fig-forth-auto680):00256 PAGE
	257	+ (fig-forth-auto680):00257 * This system is shown with one user (task),
	258	+ (fig-forth-auto680):00258 * but additional users (tasks) may be added
	259	+ (fig-forth-auto680):00259 * by allocating additional user tables:
	260	+ (fig-forth-auto680):00260 *
	261	+ (fig-forth-auto680):00261 ORG IUP
	262	+7C00 (fig-forth-auto680):00262 UBASE RMB USERSZ
	263	+7D00 (fig-forth-auto680):00263 UBASEX RMB USERSZ data table for extra users
	264	+ (fig-forth-auto680):00264 *
	265	+ (fig-forth-auto680):00265 * Some of this stuff gets initialized during
	266	+ (fig-forth-auto680):00266 * COLD start and WARM start:
	267	+ (fig-forth-auto680):00267 * [ names correspond to FORTH words of similar (no X) name ]
	268	+ (fig-forth-auto680):00268 *
	269	+ (fig-forth-auto680):00269 ORG IUP
	270	+ 7C00 (fig-forth-auto680):00270 UORIG EQU *
	271	+ (fig-forth-auto680):00271 * A few useful VM variables
	272	+ (fig-forth-auto680):00272 * Will be removed when they are no longer needed.
	273	+ (fig-forth-auto680):00273 * All are replaced by 6809 registers.
	274	+ (fig-forth-auto680):00274
	275	+7C00 (fig-forth-auto680):00275 N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
	276	+ (fig-forth-auto680):00276 * SP@,SWAP,DOES>,COLD
	277	+ (fig-forth-auto680):00277
	278	+ (fig-forth-auto680):00278
	279	+ (fig-forth-auto680):00279 * These locations are used by the TRACE routine :
	280	+ (fig-forth-auto680):00280
	281	+7C0A (fig-forth-auto680):00281 TRLIM RMB 1 the count for tracing without user intervention
	282	+7C0B (fig-forth-auto680):00282 TRACEM RMB 1 non-zero = trace mode
	283	+7C0C (fig-forth-auto680):00283 BRKPT RMB 2 the breakpoint address at which
	284	+ (fig-forth-auto680):00284 * the program will go into trace mode
	285	+7C0E (fig-forth-auto680):00285 VECT RMB 2 vector to machine code
	286	+ (fig-forth-auto680):00286 * (only needed if the TRACE routine is resident)
	287	+ (fig-forth-auto680):00287
	288	+ (fig-forth-auto680):00288
	289	+ (fig-forth-auto680):00289 * Registers used by the FORTH virtual machine:
	290	+ (fig-forth-auto680):00290 * Starting at $OOFO:
	291	+ (fig-forth-auto680):00291
	292	+ (fig-forth-auto680):00292
	293	+7C10 (fig-forth-auto680):00293 W RMB 2 the instruction register points to 6800 code
	294	+ (fig-forth-auto680):00294 * This is not exactly accurate. Points to the definiton body,
	295	+ (fig-forth-auto680):00295 * which is native CPU machine code when it is native CPU machine code.
	296	+7C12 (fig-forth-auto680):00296 IP RMB 2 the instruction pointer points to pointer to 6800 code
	297	+7C14 (fig-forth-auto680):00297 RP RMB 2 the return stack pointer
	298	+7C16 (fig-forth-auto680):00298 UP RMB 2 the pointer to base of current user's 'USER' table
	299	+ (fig-forth-auto680):00299 * ( altered during multi-tasking )
	300	+ (fig-forth-auto680):00300 *
	301	+ (fig-forth-auto680):00301 *UORIG RMB 6 3 reserved variables
	302	+7C18 (fig-forth-auto680):00302 RMB 6 3 reserved variables
	303	+7C1E (fig-forth-auto680):00303 XSPZER RMB 2 initial top of data stack for this user
	304	+7C20 (fig-forth-auto680):00304 XRZERO RMB 2 initial top of return stack
	305	+7C22 (fig-forth-auto680):00305 XTIB RMB 2 start of terminal input buffer
	306	+7C24 (fig-forth-auto680):00306 XWIDTH RMB 2 name field width
	307	+7C26 (fig-forth-auto680):00307 XWARN RMB 2 warning message mode (0 = no disc)
	308	+7C28 (fig-forth-auto680):00308 XFENCE RMB 2 fence for FORGET
	309	+7C2A (fig-forth-auto680):00309 XDICTP RMB 2 dictionary pointer
	310	+7C2C (fig-forth-auto680):00310 XVOCL RMB 2 vocabulary linking
	311	+7C2E (fig-forth-auto680):00311 XBLK RMB 2 disc block being accessed
	312	+7C30 (fig-forth-auto680):00312 XIN RMB 2 scan pointer into the block
	313	+7C32 (fig-forth-auto680):00313 XOUT RMB 2 cursor position
	314	+7C34 (fig-forth-auto680):00314 XSCR RMB 2 disc screen being accessed ( O=terminal )
	315	+7C36 (fig-forth-auto680):00315 XOFSET RMB 2 disc sector offset for multi-disc
	316	+7C38 (fig-forth-auto680):00316 XCONT RMB 2 last word in primary search vocabulary
	317	+7C3A (fig-forth-auto680):00317 XCURR RMB 2 last word in extensible vocabulary
	318	+7C3C (fig-forth-auto680):00318 XSTATE RMB 2 flag for 'interpret' or 'compile' modes
	319	+7C3E (fig-forth-auto680):00319 XBASE RMB 2 number base for I/O numeric conversion
	320	+7C40 (fig-forth-auto680):00320 XDPL RMB 2 decimal point place
	321	+7C42 (fig-forth-auto680):00321 XFLD RMB 2
	322	+7C44 (fig-forth-auto680):00322 XCSP RMB 2 current stack position, for compile checks
	323	+7C46 (fig-forth-auto680):00323 XRNUM RMB 2
	324	+7C48 (fig-forth-auto680):00324 XHLD RMB 2
	325	+7C4A (fig-forth-auto680):00325 XDELAY RMB 2 carriage return delay count
	326	+7C4C (fig-forth-auto680):00326 XCOLUM RMB 2 carriage width
	327	+7C4E (fig-forth-auto680):00327 IOSTAT RMB 2 last acia status from write/read
	328	+7C50 (fig-forth-auto680):00328 RMB 2 ( 4 spares! )
	329	+7C52 (fig-forth-auto680):00329 RMB 2
	330	+7C54 (fig-forth-auto680):00330 RMB 2
	331	+7C56 (fig-forth-auto680):00331 RMB 2
	332	+ (fig-forth-auto680):00332
	333	+ (fig-forth-auto680):00333
	334	+ (fig-forth-auto680):00334
	335	+ (fig-forth-auto680):00335
	336	+ (fig-forth-auto680):00336 *
	337	+ (fig-forth-auto680):00337 *
	338	+ (fig-forth-auto680):00338 * end of user table, start of common system variables
	339	+ (fig-forth-auto680):00339 *
	340	+ (fig-forth-auto680):00340 *
	341	+ (fig-forth-auto680):00341 *
	342	+7C58 (fig-forth-auto680):00342 XUSE RMB 2
	343	+7C5A (fig-forth-auto680):00343 XPREV RMB 2
	344	+7C5C (fig-forth-auto680):00344 RMB 4 ( spares )
	345	+ (fig-forth-auto680):00345
	346	+ (fig-forth-auto680):00346 PAGE
	347	+ (fig-forth-auto680):00347 * The FORTH program ( address $1200 to about $27FF ) will be written
	348	+ (fig-forth-auto680):00348 * so that it can be in a ROM, or write-protected if desired,
	349	+ (fig-forth-auto680):00349 * but right now we're just getting it running.
	350	+ (fig-forth-auto680):00350 ORG CODEBG
	351	+ (fig-forth-auto680):00351
	352	+ (fig-forth-auto680):00352 * ######>> screen 3 <<
	353	+ (fig-forth-auto680):00353 *
	354	+ (fig-forth-auto680):00354 ***************************
	355	+ (fig-forth-auto680):00355 C O L D E N T R Y
	356	+ (fig-forth-auto680):00356 ***************************
	357	+1200 12 (fig-forth-auto680):00357 ORIG NOP
	358	+ (fig-forth-auto680):00358 * JMP CENT
	359	+1201 171029 (fig-forth-auto680):00359 LBSR CENT
	360	+ (fig-forth-auto680):00360 ***************************
	361	+ (fig-forth-auto680):00361 W A R M E N T R Y
	362	+ (fig-forth-auto680):00362 ***************************
	363	+1204 12 (fig-forth-auto680):00363 NOP
	364	+ (fig-forth-auto680):00364 * JMP WENT warm-start code, keeps current dictionary intact
	365	+1205 171062 (fig-forth-auto680):00365 LBSR WENT warm-start code, keeps current dictionary intact
	366	+ 7C (fig-forth-auto680):00366 SETDP IUPDP
	367	+ (fig-forth-auto680):00367
	368	+ (fig-forth-auto680):00368 *
	369	+ (fig-forth-auto680):00369 ***** startup parmeters ************************
	370	+ (fig-forth-auto680):00370 *
	371	+1208 68090000 (fig-forth-auto680):00371 FDB $6809,0000 cpu & revision
	372	+120C 0000 (fig-forth-auto680):00372 FDB 0 topmost word in FORTH vocabulary
	373	+ (fig-forth-auto680):00373 * BACKSP FDB $7F backspace character for editing
	374	+120E 0008 (fig-forth-auto680):00374 BACKSP FDB $08 backspace character for editing
	375	+1210 7C00 (fig-forth-auto680):00375 UPINIT FDB UORIG initial user area
	376	+ (fig-forth-auto680):00376 * UPINIT FDB UORIG initial user area
	377	+1212 6A00 (fig-forth-auto680):00377 SINIT FDB ISP ; initial top of data stack
	378	+ (fig-forth-auto680):00378 * SINIT FDB ORIG-$D0 initial top of data stack
	379	+1214 6BE0 (fig-forth-auto680):00379 RINIT FDB IRP ; initial top of return stack
	380	+ (fig-forth-auto680):00380 * RINIT FDB ORIG-2 initial top of return stack
	381	+1216 6A00 (fig-forth-auto680):00381 FDB ITIB ; terminal input buffer
	382	+ (fig-forth-auto680):00382 * FDB ORIG-$D0 terminal input buffer
	383	+1218 001F (fig-forth-auto680):00383 FDB 31 initial name field width
	384	+121A 0000 (fig-forth-auto680):00384 FDB 0 initial warning mode (0 = no disc)
	385	+121C 2AD0 (fig-forth-auto680):00385 FENCIN FDB REND initial fence
	386	+121E 2AD0 (fig-forth-auto680):00386 DPINIT FDB REND cold start value for DICTPT
	387	+1220 2AA5 (fig-forth-auto680):00387 VOCINT FDB FORTH+4*NATWID
	388	+1222 0084 (fig-forth-auto680):00388 COLINT FDB 132 initial terminal carriage width
	389	+1224 0004 (fig-forth-auto680):00389 DELINT FDB 4 initial carriage return delay
	390	+ (fig-forth-auto680):00390 ****************************************************
	391	+ (fig-forth-auto680):00391 *
	392	+ (fig-forth-auto680):00392 PAGE
	393	+ (fig-forth-auto680):00393 *
	394	+ (fig-forth-auto680):00394 * ######>> screen 13 <<
	395	+ (fig-forth-auto680):00395 * These were of questionable use anyway,
	396	+ (fig-forth-auto680):00396 * kept here now to satisfy the assembler and show hints.
	397	+ (fig-forth-auto680):00397 * They're too much trouble to use with native subroutine call anyway.
	398	+ (fig-forth-auto680):00398 * PULABX PULS A ; 24 cycles until 'NEXT'
	399	+ (fig-forth-auto680):00399 * PULS B ;
	400	+ (fig-forth-auto680):00400 * PULABX PULU A,B ; ?? cycles until 'NEXT'
	401	+ (fig-forth-auto680):00401 * STABX STA 0,X 16 cycles until 'NEXT'
	402	+ (fig-forth-auto680):00402 * STB 1,X
	403	+ (fig-forth-auto680):00403 * STABX STD 0,X ; ?? cycles until 'NEXT'
	404	+1226 2000 (fig-forth-auto680):00404 BRA NEXT
	405	+ (fig-forth-auto680):00405 * GETX LDA 0,X 18 cycles until 'NEXT'
	406	+ (fig-forth-auto680):00406 * LDB 1,X
	407	+ (fig-forth-auto680):00407 * GETX LDD 0,X ?? cycles until 'NEXT'
	408	+ (fig-forth-auto680):00408 * PUSHBA PSHS B ; 8 cycles until 'NEXT'
	409	+ (fig-forth-auto680):00409 * PSHS A ;
	410	+ (fig-forth-auto680):00410 * PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
	411	+ (fig-forth-auto680):00411
	412	+ (fig-forth-auto680):00412
	413	+ (fig-forth-auto680):00413 *
	414	+ (fig-forth-auto680):00414 * "NEXT" takes ?? cycles if TRACE is removed,
	415	+ (fig-forth-auto680):00415 *
	416	+ (fig-forth-auto680):00416 * and ?? cycles if trace is present and NOT tracing.
	417	+ (fig-forth-auto680):00417 *
	418	+ (fig-forth-auto680):00418 * = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
	419	+ (fig-forth-auto680):00419 * =
	420	+ (fig-forth-auto680):00420 * NEXT itself might just completely go away.
	421	+ (fig-forth-auto680):00421 * About the only reason to keep it is to allowing executing a list
	422	+ (fig-forth-auto680):00422 * which allows a cheap TRACE routine.
	423	+ (fig-forth-auto680):00423 *
	424	+ (fig-forth-auto680):00424 * NEXT is a loop which implements the Forth VM.
	425	+ (fig-forth-auto680):00425 * It basically cycles through calling the code out of code lists,
	426	+ (fig-forth-auto680):00426 * one at a time.
	427	+ (fig-forth-auto680):00427 * Using a native CPU return for this uses a few extra cycles per call,
	428	+ (fig-forth-auto680):00428 * compared to simply jumping to each definition and jumping back
	429	+ (fig-forth-auto680):00429 * to the known beginning of the loop,
	430	+ (fig-forth-auto680):00430 * but the loop itself is really only there for convenience.
	431	+ (fig-forth-auto680):00431 *
	432	+ (fig-forth-auto680):00432 * This implementation uses the native subroutine call,
	433	+ (fig-forth-auto680):00433 * to break the wall between Forth code and non-Forth code.
	434	+ (fig-forth-auto680):00434 *
	435	+ (fig-forth-auto680):00435 * NEXT LDX IP
	436	+ (fig-forth-auto680):00436 * LEAX 1,X ; pre-increment mode
	437	+ (fig-forth-auto680):00437 * LEAX 1,X ;
	438	+ (fig-forth-auto680):00438 * STX IP
	439	+1228 (fig-forth-auto680):00439 NEXT ; IP is Y, push before using, pull before you come back here.
	440	+ (fig-forth-auto680):00440 *
	441	+ (fig-forth-auto680):00441 * NEXT2 LDX 0,X get W which points to CFA of word to be done
	442	+1228 AEA1 (fig-forth-auto680):00442 NEXT2 LDX ,Y++ get W which points to CFA of word to be done
	443	+122A 8D08 (fig-forth-auto680):00443 BSR DBGNAM
	444	+122C 8D58 (fig-forth-auto680):00444 BSR DBGREG
	445	+ (fig-forth-auto680):00445 * But NEXT2 is too much trouble to use with subroutine threading anyway.
	446	+ (fig-forth-auto680):00446 * NEXT3 STX W
	447	+122E (fig-forth-auto680):00447 NEXT3 ; W is X until you use X for something else. (TOS points back here.)
	448	+ (fig-forth-auto680):00448 * But NEXT3 is too much trouble to use with subroutine threading anyway.
	449	+ (fig-forth-auto680):00449 * LDX 0,X get VECT which points to executable code
	450	+ (fig-forth-auto680):00450 * =
	451	+ (fig-forth-auto680):00451 * The next instruction could be patched to JMP TRACE =
	452	+ (fig-forth-auto680):00452 * if a TRACE routine is available: =
	453	+ (fig-forth-auto680):00453 * =
	454	+ (fig-forth-auto680):00454 * JMP 0,X
	455	+ (fig-forth-auto680):00455
	456	+122E AD94 (fig-forth-auto680):00456 JSR [,X] ; Saving the postinc cycles,
	457	+ (fig-forth-auto680):00457 * ; but X must be bumped NATWID to the parameters.
	458	+ (fig-forth-auto680):00458 * NOP
	459	+ (fig-forth-auto680):00459 * JMP TRACE ( an alternate for the above )
	460	+1230 8D54 (fig-forth-auto680):00460 BSR DBGREG ( an alternate for the above )
	461	+ (fig-forth-auto680):00461 * In other words, with the call and the NOP,
	462	+ (fig-forth-auto680):00462 * there is room to patch the call with a JMP to your TRACE
	463	+ (fig-forth-auto680):00463 * routine, which you have to provide.
	464	+1232 20F4 (fig-forth-auto680):00464 BRA NEXT
	465	+ (fig-forth-auto680):00465 *
	466	+1234 3437 (fig-forth-auto680):00466 DBGNAM PSHS CC,D,X,Y
	467	+1236 0D0B (fig-forth-auto680):00467 TST <TRACEM
	468	+1238 2724 (fig-forth-auto680):00468 BEQ DBGNrt
	469	+123A 301D (fig-forth-auto680):00469 LEAX -3,X
	470	+123C E682 (fig-forth-auto680):00470 DBGNlf LDB ,-X
	471	+123E 2AFC (fig-forth-auto680):00471 BPL DBGNlf
	472	+1240 108E04C0 (fig-forth-auto680):00472 LDY #$4C0
	473	+1244 E680 (fig-forth-auto680):00473 LDB ,X+
	474	+1246 E680 (fig-forth-auto680):00474 DBGNlp LDB ,X+
	475	+1248 2B04 (fig-forth-auto680):00475 BMI DBGNll
	476	+124A E7A0 (fig-forth-auto680):00476 STB ,Y+
	477	+124C 20F8 (fig-forth-auto680):00477 BRA DBGNlp
	478	+124E C47F (fig-forth-auto680):00478 DBGNll ANDB #$7F
	479	+1250 E7A0 (fig-forth-auto680):00479 STB ,Y+
	480	+1252 C660 (fig-forth-auto680):00480 LDB #$60
	481	+1254 2002 (fig-forth-auto680):00481 BRA DBGNlt
	482	+1256 E7A0 (fig-forth-auto680):00482 DBGNlc STB ,Y+
	483	+1258 108C04E0 (fig-forth-auto680):00483 DBGNlt CMPY #$4E0
	484	+125C 25F8 (fig-forth-auto680):00484 BLO DBGNlc
	485	+125E 35B7 (fig-forth-auto680):00485 DBGNrt PULS CC,D,X,Y,PC
	486	+ (fig-forth-auto680):00486 *
	487	+ (fig-forth-auto680):00487 *
	488	+1260 54 (fig-forth-auto680):00488 MKhxBh LSRB
	489	+1261 54 (fig-forth-auto680):00489 LSRB
	490	+1262 54 (fig-forth-auto680):00490 LSRB
	491	+1263 54 (fig-forth-auto680):00491 LSRB
	492	+1264 C40F (fig-forth-auto680):00492 MKhxBl ANDB #$0F
	493	+1266 CB30 (fig-forth-auto680):00493 ADDB #$30
	494	+1268 C139 (fig-forth-auto680):00494 CMPB #$39
	495	+126A 2302 (fig-forth-auto680):00495 BLS MKhxBx
	496	+126C CBC7 (fig-forth-auto680):00496 ADDB #$C7 ; ($40-$39)-$40
	497	+126E 39 (fig-forth-auto680):00497 MKhxBx RTS
	498	+ (fig-forth-auto680):00498 *
	499	+126F 1E89 (fig-forth-auto680):00499 OUThxA EXG A,B
	500	+1271 8D05 (fig-forth-auto680):00500 BSR OUThxB
	501	+1273 1E89 (fig-forth-auto680):00501 EXG A,B
	502	+1275 39 (fig-forth-auto680):00502 RTS
	503	+ (fig-forth-auto680):00503 *
	504	+1276 8DF7 (fig-forth-auto680):00504 OUThxD BSR OUThxA
	505	+1278 3404 (fig-forth-auto680):00505 OUThxB PSHS B
	506	+127A 8DE4 (fig-forth-auto680):00506 BSR MKhxBh
	507	+127C E780 (fig-forth-auto680):00507 STB ,X+
	508	+127E E6E4 (fig-forth-auto680):00508 LDB ,S
	509	+1280 8DE2 (fig-forth-auto680):00509 BSR MKhxBl
	510	+1282 E780 (fig-forth-auto680):00510 STB ,X+
	511	+1284 3584 (fig-forth-auto680):00511 PULS B,PC
	512	+ (fig-forth-auto680):00512 *
	513	+1286 347F (fig-forth-auto680):00513 DBGREG PSHS U,Y,X,DP,B,A,CC
	514	+1288 0D0B (fig-forth-auto680):00514 TST <TRACEM
	515	+128A 102700DF (fig-forth-auto680):00515 LBEQ DBGRrt
	516	+128E 318D00DD (fig-forth-auto680):00516 LEAY DBGRLB,PCR
	517	+1292 8E04E0 (fig-forth-auto680):00517 LDX #$4E0
	518	+1295 ECA1 (fig-forth-auto680):00518 DBGRlp LDD ,Y++
	519	+1297 2704 (fig-forth-auto680):00519 BEQ DBGRdn
	520	+1299 ED81 (fig-forth-auto680):00520 STD ,X++
	521	+129B 20F8 (fig-forth-auto680):00521 BRA DBGRlp
	522	+129D 8E0500 (fig-forth-auto680):00522 DBGRdn LDX #$500
	523	+12A0 A663 (fig-forth-auto680):00523 LDA 3,S ; DP
	524	+12A2 E6E4 (fig-forth-auto680):00524 LDB ,S ; CC
	525	+12A4 8DD0 (fig-forth-auto680):00525 BSR OUThxD
	526	+12A6 C660 (fig-forth-auto680):00526 LDB #$60
	527	+12A8 E780 (fig-forth-auto680):00527 STB ,X+
	528	+12AA EC6A (fig-forth-auto680):00528 LDD 3*NATWID+4,S ; PC:505
	529	+12AC 8DC8 (fig-forth-auto680):00529 BSR OUThxD
	530	+12AE C660 (fig-forth-auto680):00530 LDB #$60
	531	+12B0 E780 (fig-forth-auto680):00531 STB ,X+
	532	+12B2 1F40 (fig-forth-auto680):00532 TFR S,D ; 509
	533	+12B4 C3000C (fig-forth-auto680):00533 ADDD #4*NATWID+4
	534	+12B7 8DBD (fig-forth-auto680):00534 BSR OUThxD
	535	+12B9 EC68 (fig-forth-auto680):00535 LDD 2*NATWID+4,S ; U:50E
	536	+12BB 8DB9 (fig-forth-auto680):00536 BSR OUThxD
	537	+12BD C660 (fig-forth-auto680):00537 LDB #$60
	538	+12BF E780 (fig-forth-auto680):00538 STB ,X+
	539	+12C1 EC66 (fig-forth-auto680):00539 LDD 1*NATWID+4,S ; Y:513
	540	+12C3 8DB1 (fig-forth-auto680):00540 BSR OUThxD
	541	+12C5 EC64 (fig-forth-auto680):00541 LDD 0*NATWID+4,S ; X at 517
	542	+12C7 8DAD (fig-forth-auto680):00542 BSR OUThxD
	543	+12C9 C660 (fig-forth-auto680):00543 LDB #$60
	544	+12CB E780 (fig-forth-auto680):00544 STB ,X+
	545	+12CD EC61 (fig-forth-auto680):00545 LDD 1,S ; D at 51C
	546	+12CF 8DA5 (fig-forth-auto680):00546 BSR OUThxD
	547	+12D1 C660 (fig-forth-auto680):00547 LDB #$60
	548	+12D3 E780 (fig-forth-auto680):00548 STB ,X+
	549	+12D5 E780 (fig-forth-auto680):00549 STB ,X+
	550	+12D7 E780 (fig-forth-auto680):00550 STB ,X+
	551	+12D9 E780 (fig-forth-auto680):00551 STB ,X+
	552	+12DB E780 (fig-forth-auto680):00552 STB ,X+
	553	+12DD ECF80A (fig-forth-auto680):00553 LDD [3*NATWID+4,S] ; PC
	554	+12E0 8D94 (fig-forth-auto680):00554 BSR OUThxD
	555	+12E2 C660 (fig-forth-auto680):00555 LDB #$60
	556	+12E4 E780 (fig-forth-auto680):00556 STB ,X+
	557	+12E6 EC6C (fig-forth-auto680):00557 LDD 4*NATWID+4,S ; S
	558	+12E8 8D8C (fig-forth-auto680):00558 BSR OUThxD
	559	+12EA ECF808 (fig-forth-auto680):00559 LDD [2*NATWID+4,S] ; U
	560	+12ED 8D87 (fig-forth-auto680):00560 BSR OUThxD
	561	+12EF C660 (fig-forth-auto680):00561 LDB #$60
	562	+12F1 E780 (fig-forth-auto680):00562 STB ,X+
	563	+12F3 ECF806 (fig-forth-auto680):00563 LDD [1*NATWID+4,S] ; Y
	564	+12F6 17FF7D (fig-forth-auto680):00564 LBSR OUThxD
	565	+12F9 ECF804 (fig-forth-auto680):00565 LDD [0*NATWID+4,S] ; X
	566	+12FC 17FF77 (fig-forth-auto680):00566 LBSR OUThxD
	567	+12FF C660 (fig-forth-auto680):00567 LDB #$60
	568	+1301 E780 (fig-forth-auto680):00568 STB ,X+
	569	+1303 E780 (fig-forth-auto680):00569 STB ,X+
	570	+1305 E780 (fig-forth-auto680):00570 STB ,X+
	571	+1307 E780 (fig-forth-auto680):00571 STB ,X+
	572	+1309 E780 (fig-forth-auto680):00572 STB ,X+
	573	+130B C600 (fig-forth-auto680):00573 LDB #0
	574	+130D 1E9B (fig-forth-auto680):00574 EXG B,DP
	575	+130F AD9FA000 (fig-forth-auto680):00575 DBGRkl JSR [$A000]
	576	+1313 27FA (fig-forth-auto680):00576 BEQ DBGRkl
	577	+1315 FD043E (fig-forth-auto680):00577 STD $43E
	578	+1318 1EB9 (fig-forth-auto680):00578 EXG DP,B
	579	+131A 8155 (fig-forth-auto680):00579 CMPA #$55 ; 'U'
	580	+131C 273C (fig-forth-auto680):00580 BEQ DBGRdU
	581	+131E 8153 (fig-forth-auto680):00581 CMPA #$53 ; 'S'
	582	+1320 271E (fig-forth-auto680):00582 BEQ DBGRdS
	583	+1322 8149 (fig-forth-auto680):00583 CMPA #$49 ; 'I'
	584	+1324 2647 (fig-forth-auto680):00584 BNE DBGRrt
	585	+1326 DC22 (fig-forth-auto680):00585 DBGRin LDD <XTIB
	586	+1328 D330 (fig-forth-auto680):00586 ADDD <XIN
	587	+132A 1F02 (fig-forth-auto680):00587 TFR D,Y
	588	+132C 17FF47 (fig-forth-auto680):00588 LBSR OUThxD
	589	+132F C63A (fig-forth-auto680):00589 LDB #$3a ; ':'
	590	+1331 E780 (fig-forth-auto680):00590 STB ,X+
	591	+1333 964C (fig-forth-auto680):00591 LDA <XCOLUM
	592	+1335 E6A0 (fig-forth-auto680):00592 DBGRip LDB ,Y+
	593	+1337 E780 (fig-forth-auto680):00593 STB ,X+
	594	+1339 2732 (fig-forth-auto680):00594 BEQ DBGRrt
	595	+133B 4A (fig-forth-auto680):00595 DBGRit DECA
	596	+133C 26F7 (fig-forth-auto680):00596 BNE DBGRip
	597	+133E 202D (fig-forth-auto680):00597 BRA DBGRrt
	598	+1340 1F42 (fig-forth-auto680):00598 DBGRdS TFR S,Y
	599	+1342 2009 (fig-forth-auto680):00599 BRA DBGRst
	600	+1344 ECA1 (fig-forth-auto680):00600 DBGRsp LDD ,Y++
	601	+1346 17FF2D (fig-forth-auto680):00601 LBSR OUThxD
	602	+1349 C660 (fig-forth-auto680):00602 LDB #$60
	603	+134B E780 (fig-forth-auto680):00603 STB ,X+
	604	+134D 109C20 (fig-forth-auto680):00604 DBGRst CMPY <XRZERO
	605	+1350 25F2 (fig-forth-auto680):00605 BLO DBGRsp
	606	+1352 C63A (fig-forth-auto680):00606 LDB #$3a ; ':'
	607	+1354 E780 (fig-forth-auto680):00607 STB ,X+
	608	+1356 C655 (fig-forth-auto680):00608 LDB #$55
	609	+1358 E780 (fig-forth-auto680):00609 STB ,X+
	610	+135A 10AE68 (fig-forth-auto680):00610 DBGRdU LDY 2*NATWID+4,S
	611	+135D 2009 (fig-forth-auto680):00611 BRA DBGRut
	612	+135F ECA1 (fig-forth-auto680):00612 DBGRup LDD ,Y++
	613	+1361 17FF12 (fig-forth-auto680):00613 LBSR OUThxD
	614	+1364 C660 (fig-forth-auto680):00614 LDB #$60
	615	+1366 E780 (fig-forth-auto680):00615 STB ,X+
	616	+1368 109C1E (fig-forth-auto680):00616 DBGRut CMPY <XSPZER
	617	+136B 25F2 (fig-forth-auto680):00617 BLO DBGRup
	618	+136D 35FF (fig-forth-auto680):00618 DBGRrt PULS CC,A,B,DP,X,Y,U,PC
	619	+136F 4450434320504320 (fig-forth-auto680):00619 DBGRLB FCC 'DPCC PC S U Y X A B '
	620	+ 2020532020205520
	621	+ 2020205920202058
	622	+ 2020202041204220
	623	+138F 00000000 (fig-forth-auto680):00620 FDB 0,0
	624	+ (fig-forth-auto680):00621
	625	+ (fig-forth-auto680):00622
	626	+ (fig-forth-auto680):00623 *
	627	+ (fig-forth-auto680):00624 * =
	628	+ (fig-forth-auto680):00625 * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
	629	+ (fig-forth-auto680):00626
	630	+ (fig-forth-auto680):00627
	631	+ (fig-forth-auto680):00628 PAGE
	632	+ (fig-forth-auto680):00629 *
	633	+ (fig-forth-auto680):00630 * ======>> 1 <<
	634	+ (fig-forth-auto680):00631 * ( --- n )
	635	+ (fig-forth-auto680):00632 * Pushes the following natural width integer from the instruction stream
	636	+ (fig-forth-auto680):00633 * as a literal, or immediate value.
	637	+ (fig-forth-auto680):00634 *
	638	+ (fig-forth-auto680):00635 * FDB {OP}
	639	+ (fig-forth-auto680):00636 * FDB {OP}
	640	+ (fig-forth-auto680):00637 * FDB LIT
	641	+ (fig-forth-auto680):00638 * FDB LITERAL-TO-BE-PUSHED
	642	+ (fig-forth-auto680):00639 * FDB {OP}
	643	+ (fig-forth-auto680):00640 *
	644	+ (fig-forth-auto680):00641 * In native processor code, there should be a better way, use that instead.
	645	+ (fig-forth-auto680):00642 * More specifically, DO NOT CALL THIS from assembly language code.
	646	+ (fig-forth-auto680):00643 * (Note that there is no compile-only flag in the fig model.)
	647	+ (fig-forth-auto680):00644 *
	648	+ (fig-forth-auto680):00645 * See (FIND), or PFIND , for layout of the header format.
	649	+ (fig-forth-auto680):00646 *
	650	+1393 83 (fig-forth-auto680):00647 FCB $83
	651	+1394 4C49 (fig-forth-auto680):00648 FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
	652	+1396 D4 (fig-forth-auto680):00649 FCB $D4 ; 'T'\|'\x80' ; character code for T, with high bit set.
	653	+1397 0000 (fig-forth-auto680):00650 FDB 0 ; link of zero to terminate dictionary scan
	654	+1399 139B (fig-forth-auto680):00651 LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
	655	+139B ECA1 (fig-forth-auto680):00652 LDD ,Y++
	656	+139D 3606 (fig-forth-auto680):00653 PSHU A,B
	657	+139F 39 (fig-forth-auto680):00654 RTS
	658	+ (fig-forth-auto680):00655 * LDX IP
	659	+ (fig-forth-auto680):00656 * LEAX 1,X ;
	660	+ (fig-forth-auto680):00657 * LEAX 1,X ;
	661	+ (fig-forth-auto680):00658 * STX IP
	662	+ (fig-forth-auto680):00659 * LDA 0,X
	663	+ (fig-forth-auto680):00660 * LDB 1,X
	664	+ (fig-forth-auto680):00661 * JMP PUSHBA
	665	+ (fig-forth-auto680):00662 *
	666	+ (fig-forth-auto680):00663 * ######>> screen 14 <<
	667	+ (fig-forth-auto680):00664 * ======>> 2 <<
	668	+ (fig-forth-auto680):00665 * ( --- n )
	669	+ (fig-forth-auto680):00666 * Pushes the following byte from the instruction stream
	670	+ (fig-forth-auto680):00667 * as a literal, or immediate value.
	671	+ (fig-forth-auto680):00668 *
	672	+ (fig-forth-auto680):00669 * FDB {OP}
	673	+ (fig-forth-auto680):00670 * FDB {OP}
	674	+ (fig-forth-auto680):00671 * FDB LIT8
	675	+ (fig-forth-auto680):00672 * FCB LITERAL-TO-BE-PUSHED
	676	+ (fig-forth-auto680):00673 * FDB {OP}
	677	+ (fig-forth-auto680):00674 *
	678	+ (fig-forth-auto680):00675 * If this is kept, it should have a header for TRACE to read.
	679	+ (fig-forth-auto680):00676 * If the data bus is wider than a byte, you don't want to do this.
	680	+ (fig-forth-auto680):00677 * Byte shaving like this is often counter-productive anyway.
	681	+ (fig-forth-auto680):00678 * Changing the name to LIT8, hoping that will be more understandable.
	682	+ (fig-forth-auto680):00679 * Also, see comments for LIT.
	683	+ (fig-forth-auto680):00680 * (Note that there is no compile-only flag in the fig model.)
	684	+13A0 84 (fig-forth-auto680):00681 FCB $84
	685	+13A1 4C4954 (fig-forth-auto680):00682 FCC 'LIT' ; 'LIT8' : NOTE: this is different from LITERAL
	686	+13A4 B8 (fig-forth-auto680):00683 FCB $B8
	687	+13A5 1393 (fig-forth-auto680):00684 FDB LIT-6
	688	+13A7 13A9 (fig-forth-auto680):00685 LIT8 FDB *+NATWID (this was an invisible word, with no header)
	689	+13A9 E6A0 (fig-forth-auto680):00686 LDB ,Y+ ; This also is meaningless in native code.
	690	+13AB 4F (fig-forth-auto680):00687 CLRA
	691	+13AC 3606 (fig-forth-auto680):00688 PSHU A,B
	692	+13AE 39 (fig-forth-auto680):00689 RTS
	693	+ (fig-forth-auto680):00690 * LDX IP
	694	+ (fig-forth-auto680):00691 * LEAX 1,X ;
	695	+ (fig-forth-auto680):00692 * STX IP
	696	+ (fig-forth-auto680):00693 * CLRA ;
	697	+ (fig-forth-auto680):00694 * LDB 1,X
	698	+ (fig-forth-auto680):00695 * JMP PUSHBA
	699	+ (fig-forth-auto680):00696 *
	700	+ (fig-forth-auto680):00697 * ( n off --- n )
	701	+ (fig-forth-auto680):00698 * off is offset in video buffer area.
	702	+13AF 87 (fig-forth-auto680):00699 FCB $87
	703	+13B0 53484F57544F (fig-forth-auto680):00700 FCC 'SHOWTO' ; 'SHOWTOS'
	704	+13B6 D3 (fig-forth-auto680):00701 FCB $D3 ; 'S'
	705	+13B7 13A0 (fig-forth-auto680):00702 FDB LIT8-7
	706	+13B9 13BB (fig-forth-auto680):00703 SHOTOS FDB *+NATWID
	707	+13BB 8E0400 (fig-forth-auto680):00704 LDX #$400
	708	+13BE ECC1 (fig-forth-auto680):00705 LDD ,U++
	709	+13C0 308B (fig-forth-auto680):00706 LEAX D,X
	710	+13C2 ECC4 (fig-forth-auto680):00707 LDD ,U
	711	+13C4 17FEAF (fig-forth-auto680):00708 LBSR OUThxD
	712	+13C7 39 (fig-forth-auto680):00709 RTS
	713	+ (fig-forth-auto680):00710 *
	714	+13C8 85 (fig-forth-auto680):00711 FCB $85
	715	+13C9 54524F46 (fig-forth-auto680):00712 FCC 'TROF' ; 'TROFF'
	716	+13CD C6 (fig-forth-auto680):00713 FCB $C6 ; 'F'\|$80
	717	+13CE 13AF (fig-forth-auto680):00714 FDB SHOTOS-10
	718	+13D0 13D2 (fig-forth-auto680):00715 TROFF FDB *+NATWID
	719	+13D2 0F0B (fig-forth-auto680):00716 CLR <TRACEM
	720	+13D4 39 (fig-forth-auto680):00717 RTS
	721	+ (fig-forth-auto680):00718 *
	722	+13D5 84 (fig-forth-auto680):00719 FCB $84
	723	+13D6 54524F (fig-forth-auto680):00720 FCC 'TRO' ; 'TRON'
	724	+13D9 CE (fig-forth-auto680):00721 FCB $CE ; 'N'\|$80
	725	+13DA 13C8 (fig-forth-auto680):00722 FDB TROFF-8
	726	+13DC 13DE (fig-forth-auto680):00723 TRON FDB *+NATWID
	727	+13DE 0C0B (fig-forth-auto680):00724 INC <TRACEM
	728	+13E0 39 (fig-forth-auto680):00725 RTS
	729	+ (fig-forth-auto680):00726 *
	730	+ (fig-forth-auto680):00727 * ======>> 3 <<
	731	+ (fig-forth-auto680):00728 * ( adr --- )
	732	+ (fig-forth-auto680):00729 * Jump to address on stack. Used by the "outer" interpreter to
	733	+ (fig-forth-auto680):00730 * interactively invoke routines.
	734	+ (fig-forth-auto680):00731 * Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
	735	+13E1 87 (fig-forth-auto680):00732 FCB $87
	736	+13E2 455845435554 (fig-forth-auto680):00733 FCC 'EXECUT' ; 'EXECUTE'
	737	+13E8 C5 (fig-forth-auto680):00734 FCB $C5
	738	+13E9 13D5 (fig-forth-auto680):00735 FDB TRON-7
	739	+13EB 13ED (fig-forth-auto680):00736 EXEC FDB *+NATWID
	740	+13ED 3710 (fig-forth-auto680):00737 PULU X ; Gotta have W anyway, just in case.
	741	+13EF 6E94 (fig-forth-auto680):00738 JMP [,X] ; Tail return.
	742	+ (fig-forth-auto680):00739 * TFR S,X ; TSX :
	743	+ (fig-forth-auto680):00740 * LDX 0,X get code field address (CFA)
	744	+ (fig-forth-auto680):00741 * LEAS 1,S ; pop stack
	745	+ (fig-forth-auto680):00742 * LEAS 1,S ;
	746	+ (fig-forth-auto680):00743 * JMP NEXT3
	747	+ (fig-forth-auto680):00744 *
	748	+ (fig-forth-auto680):00745 * ######>> screen 15 <<
	749	+ (fig-forth-auto680):00746 * ======>> 4 <<
	750	+ (fig-forth-auto680):00747 * ( --- ) C
	751	+ (fig-forth-auto680):00748 * Add the following word from the instruction stream to the
	752	+ (fig-forth-auto680):00749 * instruction pointer (Y++). Causes a program branch in Forth code stream.
	753	+ (fig-forth-auto680):00750 *
	754	+ (fig-forth-auto680):00751 * In native processor code, there should be a better way, use that instead.
	755	+ (fig-forth-auto680):00752 * More specifically, DO NOT CALL THIS from assembly language code.
	756	+ (fig-forth-auto680):00753 * This is only for Forth code stream.
	757	+ (fig-forth-auto680):00754 * Also, see comments for LIT.
	758	+13F1 86 (fig-forth-auto680):00755 FCB $86
	759	+13F2 4252414E43 (fig-forth-auto680):00756 FCC 'BRANC' ; 'BRANCH'
	760	+13F7 C8 (fig-forth-auto680):00757 FCB $C8
	761	+13F8 13E1 (fig-forth-auto680):00758 FDB EXEC-10
	762	+13FA 140F (fig-forth-auto680):00759 BRAN FDB ZBYES ; Go steal code in ZBRANCH
	763	+ (fig-forth-auto680):00760
	764	+ (fig-forth-auto680):00761 * Moving code around to optimize the branch taking case in 0BRANCH.
	765	+13FC 3122 (fig-forth-auto680):00762 ZBNO LEAY NATWID,Y ; No branch.
	766	+13FE 39 (fig-forth-auto680):00763 RTS
	767	+ (fig-forth-auto680):00764 * ======>> 5 <<
	768	+ (fig-forth-auto680):00765 * ( f --- ) C
	769	+ (fig-forth-auto680):00766 * BRANCH if flag is zero.
	770	+ (fig-forth-auto680):00767 *
	771	+ (fig-forth-auto680):00768 * In native processor code, there should be a better way, use that instead.
	772	+ (fig-forth-auto680):00769 * More specifically, DO NOT CALL THIS from assembly language code.
	773	+ (fig-forth-auto680):00770 * This is only for Forth code stream.
	774	+ (fig-forth-auto680):00771 * Also, see comments for LIT.
	775	+13FF 87 (fig-forth-auto680):00772 FCB $87
	776	+1400 304252414E43 (fig-forth-auto680):00773 FCC '0BRANC' ; '0BRANCH'
	777	+1406 C8 (fig-forth-auto680):00774 FCB $C8
	778	+1407 13F1 (fig-forth-auto680):00775 FDB BRAN-9
	779	+1409 140B (fig-forth-auto680):00776 ZBRAN FDB *+NATWID
	780	+140B ECC1 (fig-forth-auto680):00777 LDD ,U++
	781	+140D 26ED (fig-forth-auto680):00778 BNE ZBNO
	782	+140F ECA1 (fig-forth-auto680):00779 ZBYES LDD ,Y++
	783	+1411 31AB (fig-forth-auto680):00780 LEAY D,Y ; IP is postinc
	784	+1413 39 (fig-forth-auto680):00781 RTS
	785	+ (fig-forth-auto680):00782 * PULS A ;
	786	+ (fig-forth-auto680):00783 * PULS B ;
	787	+ (fig-forth-auto680):00784 * PSHS B ; ** emulating ABA:
	788	+ (fig-forth-auto680):00785 * ADDA ,S+ ;
	789	+ (fig-forth-auto680):00786 * BNE ZBNO
	790	+ (fig-forth-auto680):00787 * BCS ZBNO
	791	+ (fig-forth-auto680):00788 * ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
	792	+ (fig-forth-auto680):00789 * LDB 3,X
	793	+ (fig-forth-auto680):00790 * LDA 2,X
	794	+ (fig-forth-auto680):00791 * ADDB IP+1
	795	+ (fig-forth-auto680):00792 * ADCA IP
	796	+ (fig-forth-auto680):00793 * STB IP+1
	797	+ (fig-forth-auto680):00794 * STA IP
	798	+ (fig-forth-auto680):00795 * JMP NEXT
	799	+ (fig-forth-auto680):00796 * ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
	800	+ (fig-forth-auto680):00797 * LEAX 1,X ; jump over branch delta
	801	+ (fig-forth-auto680):00798 * LEAX 1,X ;
	802	+ (fig-forth-auto680):00799 * STX IP
	803	+ (fig-forth-auto680):00800 * JMP NEXT
	804	+ (fig-forth-auto680):00801 *
	805	+ (fig-forth-auto680):00802 * ######>> screen 16 <<
	806	+ (fig-forth-auto680):00803 * ======>> 6 <<
	807	+ (fig-forth-auto680):00804 * ( --- ) ( limit index *** limit index+1) C
	808	+ (fig-forth-auto680):00805 * ( limit index *** )
	809	+ (fig-forth-auto680):00806 * Counting loop primitive. The counter and limit are the top two
	810	+ (fig-forth-auto680):00807 * words on the return stack. If the updated index/counter does
	811	+ (fig-forth-auto680):00808 * not exceed the limit, a branch occurs. If it does, the branch
	812	+ (fig-forth-auto680):00809 * does not occur, and the index and limit are dropped from the
	813	+ (fig-forth-auto680):00810 * return stack.
	814	+ (fig-forth-auto680):00811 *
	815	+ (fig-forth-auto680):00812 * In native processor code, there should be a better way, use that instead.
	816	+ (fig-forth-auto680):00813 * More specifically, DO NOT CALL THIS from assembly language code.
	817	+ (fig-forth-auto680):00814 * This is only for Forth code stream.
	818	+ (fig-forth-auto680):00815 * Also, see comments for LIT.
	819	+1414 86 (fig-forth-auto680):00816 FCB $86
	820	+1415 284C4F4F50 (fig-forth-auto680):00817 FCC '(LOOP' ; '(LOOP)'
	821	+141A A9 (fig-forth-auto680):00818 FCB $A9
	822	+141B 13FF (fig-forth-auto680):00819 FDB ZBRAN-10
	823	+141D 141F (fig-forth-auto680):00820 XLOOP FDB *+NATWID
	824	+141F CC0001 (fig-forth-auto680):00821 LDD #1 ; Borrowing from BIF-6809.
	825	+1422 E362 (fig-forth-auto680):00822 XLOOPA ADDD NATWID,S ; Dodge the return address.
	826	+1424 ED62 (fig-forth-auto680):00823 STD NATWID,S
	827	+1426 A364 (fig-forth-auto680):00824 SUBD 2*NATWID,S
	828	+1428 2DE5 (fig-forth-auto680):00825 BLT ZBYES ; signed
	829	+142A 3122 (fig-forth-auto680):00826 XLOOPN LEAY NATWID,Y
	830	+142C AEE4 (fig-forth-auto680):00827 LDX ,S ; synthetic return
	831	+142E 3266 (fig-forth-auto680):00828 LEAS 3*NATWID,S ; Clean up the index and limit.
	832	+1430 6E84 (fig-forth-auto680):00829 JMP ,X
	833	+ (fig-forth-auto680):00830 * CLRA ;
	834	+ (fig-forth-auto680):00831 * LDB #1 get set to increment counter by 1 (Clears N.)
	835	+ (fig-forth-auto680):00832 * BRA XPLOP2 go steal other guy's code!
	836	+ (fig-forth-auto680):00833 *
	837	+ (fig-forth-auto680):00834 * ======>> 7 <<
	838	+ (fig-forth-auto680):00835 * ( n --- ) ( limit index *** limit index+n ) C
	839	+ (fig-forth-auto680):00836 * ( limit index *** )
	840	+ (fig-forth-auto680):00837 * Loop with a variable increment. Terminates when the index
	841	+ (fig-forth-auto680):00838 * crosses the boundary from one below the limit to the limit. A
	842	+ (fig-forth-auto680):00839 * positive n will cause termination if the result index equals the
	843	+ (fig-forth-auto680):00840 * limit. A negative n must cause the index to become less than
	844	+ (fig-forth-auto680):00841 * the limit to cause loop termination.
	845	+ (fig-forth-auto680):00842 *
	846	+ (fig-forth-auto680):00843 * Note that the end conditions are not symmetric around zero.
	847	+ (fig-forth-auto680):00844 *
	848	+ (fig-forth-auto680):00845 * In native processor code, there should be a better way, use that instead.
	849	+ (fig-forth-auto680):00846 * More specifically, DO NOT CALL THIS from assembly language code.
	850	+ (fig-forth-auto680):00847 * This is only for Forth code stream.
	851	+ (fig-forth-auto680):00848 * Also, see comments for LIT.
	852	+1432 87 (fig-forth-auto680):00849 FCB $87
	853	+1433 282B4C4F4F50 (fig-forth-auto680):00850 FCC '(+LOOP' ; '(+LOOP)'
	854	+1439 A9 (fig-forth-auto680):00851 FCB $A9
	855	+143A 1414 (fig-forth-auto680):00852 FDB XLOOP-9
	856	+143C 143E (fig-forth-auto680):00853 XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
	857	+143E ECC1 (fig-forth-auto680):00854 LDD ,U++ ; inc val
	858	+1440 2AE0 (fig-forth-auto680):00855 BPL XLOOPA ; Steal plain loop code for forward count.
	859	+1442 E362 (fig-forth-auto680):00856 ADDD NATWID,S ; Dodge the return address
	860	+1444 ED62 (fig-forth-auto680):00857 STD NATWID,S
	861	+1446 A364 (fig-forth-auto680):00858 SUBD 2*NATWID,S
	862	+1448 2EC5 (fig-forth-auto680):00859 BGT ZBYES ; signed
	863	+144A 20DE (fig-forth-auto680):00860 BRA XLOOPN ; This path is less time-sensitive.
	864	+ (fig-forth-auto680):00861 *
	865	+ (fig-forth-auto680):00862 * This should work, but I want to use tested code.
	866	+ (fig-forth-auto680):00863 * PULU A,B ; Get the increment.
	867	+ (fig-forth-auto680):00864 * XPLOP2 PULS X ; Pre-clear the return stack.
	868	+ (fig-forth-auto680):00865 * PSHU A ; Save the direction in high bit.
	869	+ (fig-forth-auto680):00866 * ADDD ,S ; Count.
	870	+ (fig-forth-auto680):00867 * STD ,S ; Update.
	871	+ (fig-forth-auto680):00868 * SUBD NATWID,S ; Check limit.
	872	+ (fig-forth-auto680):00869 **
	873	+ (fig-forth-auto680):00870 ** I think this should work:
	874	+ (fig-forth-auto680):00871 * EORA ,U+ ; dir < 0 and (count - limit) >= 0
	875	+ (fig-forth-auto680):00872 * BPL XPLONO ; or dir >= 0 and (count - limit) < 0
	876	+ (fig-forth-auto680):00873 * LDD ,Y++
	877	+ (fig-forth-auto680):00874 * LEAY D,Y ; IP is postinc
	878	+ (fig-forth-auto680):00875 * JMP ,X
	879	+ (fig-forth-auto680):00876 * XPLONO LEAS 2*NATWID,S
	880	+ (fig-forth-auto680):00877 * JMP ,X ; synthetic return
	881	+ (fig-forth-auto680):00878 *
	882	+ (fig-forth-auto680):00879 * This definitely should work:
	883	+ (fig-forth-auto680):00880 * TST ,U+ ; Get the sign
	884	+ (fig-forth-auto680):00881 * BPL XPLOF ;
	885	+ (fig-forth-auto680):00882 * CMPD NATWID,S
	886	+ (fig-forth-auto680):00883 * BMI XPLONO
	887	+ (fig-forth-auto680):00884 * XPLOYE LDD ,Y++
	888	+ (fig-forth-auto680):00885 * LEAY D,Y ; IP is postinc
	889	+ (fig-forth-auto680):00886 * JMP ,X
	890	+ (fig-forth-auto680):00887 * XPLOF CMPD NATWID,S
	891	+ (fig-forth-auto680):00888 * BMI XPLOYE
	892	+ (fig-forth-auto680):00889 * XPLONO LEAS 2*NATWID,S
	893	+ (fig-forth-auto680):00890 * JMP ,X ; synthetic return
	894	+ (fig-forth-auto680):00891 *
	895	+ (fig-forth-auto680):00892 * 6800 Probably could have used the exclusive-or method, too.:
	896	+ (fig-forth-auto680):00893 * PULS A ; get increment
	897	+ (fig-forth-auto680):00894 * PULS B ;
	898	+ (fig-forth-auto680):00895 * XPLOP2 TSTA ;
	899	+ (fig-forth-auto680):00896 * BPL XPLOF forward looping
	900	+ (fig-forth-auto680):00897 * BSR XPLOPS
	901	+ (fig-forth-auto680):00898 * ORCC #$01 ; SEC :
	902	+ (fig-forth-auto680):00899 * SBCB 5,X
	903	+ (fig-forth-auto680):00900 * SBCA 4,X
	904	+ (fig-forth-auto680):00901 * BPL ZBYES
	905	+ (fig-forth-auto680):00902 * BRA XPLONO fall through
	906	+ (fig-forth-auto680):00903 *
	907	+ (fig-forth-auto680):00904 * the subroutine :
	908	+ (fig-forth-auto680):00905 * XPLOPS LDX RP
	909	+ (fig-forth-auto680):00906 * ADDB 3,X add it to counter
	910	+ (fig-forth-auto680):00907 * ADCA 2,X
	911	+ (fig-forth-auto680):00908 * STB 3,X store new counter value
	912	+ (fig-forth-auto680):00909 * STA 2,X
	913	+ (fig-forth-auto680):00910 * RTS
	914	+ (fig-forth-auto680):00911 *
	915	+ (fig-forth-auto680):00912 * XPLOF BSR XPLOPS
	916	+ (fig-forth-auto680):00913 * SUBB 5,X
	917	+ (fig-forth-auto680):00914 * SBCA 4,X
	918	+ (fig-forth-auto680):00915 * BMI ZBYES
	919	+ (fig-forth-auto680):00916 *
	920	+ (fig-forth-auto680):00917 * XPLONO LEAX 1,X ; done, don't branch back
	921	+ (fig-forth-auto680):00918 * LEAX 1,X ;
	922	+ (fig-forth-auto680):00919 * LEAX 1,X ;
	923	+ (fig-forth-auto680):00920 * LEAX 1,X ;
	924	+ (fig-forth-auto680):00921 * STX RP
	925	+ (fig-forth-auto680):00922 * BRA ZBNO use ZBRAN to skip over unused delta
	926	+ (fig-forth-auto680):00923 *
	927	+ (fig-forth-auto680):00924 * ######>> screen 17 <<
	928	+ (fig-forth-auto680):00925 * ======>> 8 <<
	929	+ (fig-forth-auto680):00926 * ( limit index --- ) ( *** limit index )
	930	+ (fig-forth-auto680):00927 * Move the loop parameters to the return stack. Synonym for D>R.
	931	+144C 84 (fig-forth-auto680):00928 FCB $84
	932	+144D 28444F (fig-forth-auto680):00929 FCC '(DO' ; '(DO)'
	933	+1450 A9 (fig-forth-auto680):00930 FCB $A9
	934	+1451 1432 (fig-forth-auto680):00931 FDB XPLOOP-10
	935	+1453 1455 (fig-forth-auto680):00932 XDO FDB *+NATWID This is the RUNTIME DO, not the COMPILING DO
	936	+1455 AEE4 (fig-forth-auto680):00933 LDX ,S ; Save the return address.
	937	+1457 3706 (fig-forth-auto680):00934 PULU A,B
	938	+1459 3406 (fig-forth-auto680):00935 PSHS A,B
	939	+145B 3706 (fig-forth-auto680):00936 PULU A,B ; Maintain order.
	940	+145D ED62 (fig-forth-auto680):00937 STD NATWID,S
	941	+145F 6E84 (fig-forth-auto680):00938 JMP ,X ; synthetic return
	942	+ (fig-forth-auto680):00939 *
	943	+ (fig-forth-auto680):00940 * LDX RP
	944	+ (fig-forth-auto680):00941 * LEAX -1,X ;
	945	+ (fig-forth-auto680):00942 * LEAX -1,X ;
	946	+ (fig-forth-auto680):00943 * LEAX -1,X ;
	947	+ (fig-forth-auto680):00944 * LEAX -1,X ;
	948	+ (fig-forth-auto680):00945 * STX RP
	949	+ (fig-forth-auto680):00946 * PULS A ;
	950	+ (fig-forth-auto680):00947 * PULS B ;
	951	+ (fig-forth-auto680):00948 * STA 2,X
	952	+ (fig-forth-auto680):00949 * STB 3,X
	953	+ (fig-forth-auto680):00950 * PULS A ;
	954	+ (fig-forth-auto680):00951 * PULS B ;
	955	+ (fig-forth-auto680):00952 * STA 4,X
	956	+ (fig-forth-auto680):00953 * STB 5,X
	957	+ (fig-forth-auto680):00954 * JMP NEXT
	958	+ (fig-forth-auto680):00955 *
	959	+ (fig-forth-auto680):00956 * ======>> 9 <<
	960	+ (fig-forth-auto680):00957 * ( --- index ) ( limit index *** limit index )
	961	+ (fig-forth-auto680):00958 * Copy the loop index from the return stack. Synonym for R.
	962	+1461 81 (fig-forth-auto680):00959 FCB $81 I
	963	+1462 C9 (fig-forth-auto680):00960 FCB $C9
	964	+1463 144C (fig-forth-auto680):00961 FDB XDO-7
	965	+1465 1467 (fig-forth-auto680):00962 I FDB *+NATWID
	966	+1467 EC62 (fig-forth-auto680):00963 LDD NATWID,S ; Dodge return address.
	967	+1469 3606 (fig-forth-auto680):00964 PSHU A,B
	968	+146B 39 (fig-forth-auto680):00965 RTS
	969	+ (fig-forth-auto680):00966 * LDX RP
	970	+ (fig-forth-auto680):00967 * LEAX 1,X ;
	971	+ (fig-forth-auto680):00968 * LEAX 1,X ;
	972	+ (fig-forth-auto680):00969 * JMP GETX
	973	+ (fig-forth-auto680):00970 *
	974	+ (fig-forth-auto680):00971 * ######>> screen 18 <<
	975	+ (fig-forth-auto680):00972 * ======>> 10 <<
	976	+ (fig-forth-auto680):00973 * ( c base --- false )
	977	+ (fig-forth-auto680):00974 * ( c base --- n true )
	978	+ (fig-forth-auto680):00975 * Translate C in base, yielding a translation valid flag. If the
	979	+ (fig-forth-auto680):00976 * translation is not valid in the specified base, only the false
	980	+ (fig-forth-auto680):00977 * flag is returned.
	981	+146C 85 (fig-forth-auto680):00978 FCB $85
	982	+146D 44494749 (fig-forth-auto680):00979 FCC 'DIGI' ; 'DIGIT'
	983	+1471 D4 (fig-forth-auto680):00980 FCB $D4
	984	+1472 1461 (fig-forth-auto680):00981 FDB I-4
	985	+1474 1476 (fig-forth-auto680):00982 DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
	986	+1476 EC42 (fig-forth-auto680):00983 LDD NATWID,U ; Check the whole thing.
	987	+1478 830030 (fig-forth-auto680):00984 SUBD #$30 ; ascii zero
	988	+147B 2B22 (fig-forth-auto680):00985 BMI DIGIT2 IF LESS THAN '0', ILLEGAL
	989	+147D 1083000A (fig-forth-auto680):00986 CMPD #$A
	990	+1481 2B0F (fig-forth-auto680):00987 BMI DIGIT0 IF '9' OR LESS
	991	+1483 10830011 (fig-forth-auto680):00988 CMPD #$11
	992	+1487 2B16 (fig-forth-auto680):00989 BMI DIGIT2 if less than 'A'
	993	+1489 1083002B (fig-forth-auto680):00990 CMPD #$2B
	994	+148D 2A10 (fig-forth-auto680):00991 BPL DIGIT2 if greater than 'Z'
	995	+148F 830007 (fig-forth-auto680):00992 SUBD #7 translate 'A' thru 'F'
	996	+1492 10A3C4 (fig-forth-auto680):00993 DIGIT0 CMPD ,U ; Check the base.
	997	+1495 2A08 (fig-forth-auto680):00994 BPL DIGIT2 if not less than the base
	998	+1497 ED42 (fig-forth-auto680):00995 STD NATWID,U ; Store converted digit. (High byte known zero.)
	999	+1499 CC0001 (fig-forth-auto680):00996 LDD #1 ; set valid flag
	1000	+149C EDC4 (fig-forth-auto680):00997 DIGIT1 STD ,U ; store the flag
	1001	+149E 39 (fig-forth-auto680):00998 RTS NEXT
	1002	+149F CC0000 (fig-forth-auto680):00999 DIGIT2 LDD #0 ; set not valid flag
	1003	+14A2 3342 (fig-forth-auto680):01000 LEAU NATWID,U ; pop base
	1004	+14A4 20F6 (fig-forth-auto680):01001 BRA DIGIT1
	1005	+ (fig-forth-auto680):01002 * TFR S,X ; TSX :
	1006	+ (fig-forth-auto680):01003 * LDA 3,X
	1007	+ (fig-forth-auto680):01004 * SUBA #$30 ascii zero
	1008	+ (fig-forth-auto680):01005 * BMI DIGIT2 IF LESS THAN '0', ILLEGAL
	1009	+ (fig-forth-auto680):01006 * CMPA #$A
	1010	+ (fig-forth-auto680):01007 * BMI DIGIT0 IF '9' OR LESS
	1011	+ (fig-forth-auto680):01008 * CMPA #$11
	1012	+ (fig-forth-auto680):01009 * BMI DIGIT2 if less than 'A'
	1013	+ (fig-forth-auto680):01010 * CMPA #$2B
	1014	+ (fig-forth-auto680):01011 * BPL DIGIT2 if greater than 'Z'
	1015	+ (fig-forth-auto680):01012 * SUBA #7 translate 'A' thru 'F'
	1016	+ (fig-forth-auto680):01013 * DIGIT0 CMPA 1,X
	1017	+ (fig-forth-auto680):01014 * BPL DIGIT2 if not less than the base
	1018	+ (fig-forth-auto680):01015 * LDB #1 set flag
	1019	+ (fig-forth-auto680):01016 * STA 3,X store digit
	1020	+ (fig-forth-auto680):01017 * DIGIT1 STB 1,X store the flag
	1021	+ (fig-forth-auto680):01018 * JMP NEXT
	1022	+ (fig-forth-auto680):01019 * DIGIT2 CLRB ;
	1023	+ (fig-forth-auto680):01020 * LEAS 1,S ;
	1024	+ (fig-forth-auto680):01021 * LEAS 1,S ; pop bottom number
	1025	+ (fig-forth-auto680):01022 * TFR S,X ; TSX :
	1026	+ (fig-forth-auto680):01023 * STB 0,X make sure both bytes are 00
	1027	+ (fig-forth-auto680):01024 * BRA DIGIT1
	1028	+ (fig-forth-auto680):01025 *
	1029	+ (fig-forth-auto680):01026 * ######>> screen 19 <<
	1030	+ (fig-forth-auto680):01027 *
	1031	+ (fig-forth-auto680):01028 * The word definition format in the dictionary:
	1032	+ (fig-forth-auto680):01029 *
	1033	+ (fig-forth-auto680):01030 * (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
	1034	+ (fig-forth-auto680):01031 *
	1035	+ (fig-forth-auto680):01032 * NFA (name field address):
	1036	+ (fig-forth-auto680):01033 * char-count + $80 Length of symbol name, flagged with high bit set.
	1037	+ (fig-forth-auto680):01034 * char 1 Characters of symbol name.
	1038	+ (fig-forth-auto680):01035 * char 2
	1039	+ (fig-forth-auto680):01036 * ...
	1040	+ (fig-forth-auto680):01037 * char n + $80 symbol termination flag (char set < 128 code points)
	1041	+ (fig-forth-auto680):01038 * LFA (link field address):
	1042	+ (fig-forth-auto680):01039 * link high byte \___pointer to previous word in list
	1043	+ (fig-forth-auto680):01040 * link low byte / -- Combined allocation/dictionary list. --
	1044	+ (fig-forth-auto680):01041 * CFA (code field address):
	1045	+ (fig-forth-auto680):01042 * CFA high byte \___pointer to native CPU machine code
	1046	+ (fig-forth-auto680):01043 * CFA low byte / -- Consider this the characteristic code. --
	1047	+ (fig-forth-auto680):01044 * PFA (parameter field address):
	1048	+ (fig-forth-auto680):01045 * parameter fields -- Machine code for low-level native machine CPU code,
	1049	+ (fig-forth-auto680):01046 * " instruction list for high-level Forth code,
	1050	+ (fig-forth-auto680):01047 * " constant data for constants, pointers to per task variables,
	1051	+ (fig-forth-auto680):01048 * " space for variables, for global variables, etc.
	1052	+ (fig-forth-auto680):01049 *
	1053	+ (fig-forth-auto680):01050 * In the case of native CPU machine code, the address at CFA will be PFA.
	1054	+ (fig-forth-auto680):01051
	1055	+ (fig-forth-auto680):01052 * Definition attributes:
	1056	+ 0040 (fig-forth-auto680):01053 FIMMED EQU $40 ; Immediate word flag.
	1057	+ 0020 (fig-forth-auto680):01054 FSMUDG EQU $20 ; Smudged => definition not ready.
	1058	+ 003F (fig-forth-auto680):01055 CTMASK EQU ($FF&(^($80\|FIMMED))) ; For unmasking the length byte.
	1059	+ (fig-forth-auto680):01056 * Note that the SMUDGE bit is not masked out.
	1060	+ (fig-forth-auto680):01057 *
	1061	+ (fig-forth-auto680):01058 * But we really want more (Thinking for a new model, need one more byte):
	1062	+ (fig-forth-auto680):01059 * FCOMPI EQU $10 ; Compile-time-only.
	1063	+ (fig-forth-auto680):01060 * FASSEM EQU $08 ; Assembly-language code only.
	1064	+ (fig-forth-auto680):01061 * F4THLV EQU $04 ; Must not be called from assembly language code.
	1065	+ (fig-forth-auto680):01062 * These would require some significant adjustments to the model.
	1066	+ (fig-forth-auto680):01063 * We also want to put the low-level VM stuff in its own vocabulary.
	1067	+ (fig-forth-auto680):01064 *
	1068	+ (fig-forth-auto680):01065 * ======>> 11 <<
	1069	+ (fig-forth-auto680):01066 * (FIND) ( name vocptr --- locptr length true )
	1070	+ (fig-forth-auto680):01067 * ( name vocptr --- false )
	1071	+ (fig-forth-auto680):01068 * Search vocabulary for a symbol called name.
	1072	+ (fig-forth-auto680):01069 * name is a pointer to a high-bit bracket string with length head.
	1073	+ (fig-forth-auto680):01070 * vocptr is a pointer to the NFA of the tail-end (LATEST) definition
	1074	+ (fig-forth-auto680):01071 * in the vocabulary to be searched.
	1075	+ (fig-forth-auto680):01072 * Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
	1076	+14A6 86 (fig-forth-auto680):01073 FCB $86
	1077	+14A7 2846494E44 (fig-forth-auto680):01074 FCC '(FIND' ; '(FIND)'
	1078	+14AC A9 (fig-forth-auto680):01075 FCB $A9
	1079	+14AD 146C (fig-forth-auto680):01076 FDB DIGIT-8
	1080	+14AF 14B1 (fig-forth-auto680):01077 PFIND FDB *+NATWID
	1081	+14B1 3420 (fig-forth-auto680):01078 PSHS Y ; Have to track two pointers.
	1082	+ (fig-forth-auto680):01079 * Use the stack and registers instead of temp area N.
	1083	+ 0002 (fig-forth-auto680):01080 PA0 EQU NATWID ; pointer to the length byte of name being searched against
	1084	+ 0000 (fig-forth-auto680):01081 PD EQU 0 ; pointer to NFA of dict word being checked
	1085	+ (fig-forth-auto680):01082 *
	1086	+ (fig-forth-auto680):01083 * INC <TRACEM
	1087	+ (fig-forth-auto680):01084 * LBSR DBGREG
	1088	+14B3 AEC4 (fig-forth-auto680):01085 LDX PD,U ; Start in on the vocabulary (NFA).
	1089	+14B5 10AE42 (fig-forth-auto680):01086 PFNDLP LDY PA0,U ; Point to the name to check against.
	1090	+14B8 E680 (fig-forth-auto680):01087 LDB ,X+ ; get dict name length byte
	1091	+14BA 1F98 (fig-forth-auto680):01088 TFR B,A ; Save it in case it matches.
	1092	+14BC C43F (fig-forth-auto680):01089 ANDB #CTMASK
	1093	+ (fig-forth-auto680):01090 * LBSR DBGREG
	1094	+14BE E1A0 (fig-forth-auto680):01091 CMPB ,Y+ ; Compare lengths
	1095	+ (fig-forth-auto680):01092 * LBSR DBGREG
	1096	+14C0 261C (fig-forth-auto680):01093 BNE PFNDUN
	1097	+14C2 E680 (fig-forth-auto680):01094 PFNDBR LDB ,X+
	1098	+14C4 5D (fig-forth-auto680):01095 TSTB ; ; Is high bit of character in dictionary entry set?
	1099	+ (fig-forth-auto680):01096 * LBSR DBGREG
	1100	+14C5 2A13 (fig-forth-auto680):01097 BPL PFNDCH
	1101	+ (fig-forth-auto680):01098 * LBSR DBGREG
	1102	+14C7 C47F (fig-forth-auto680):01099 ANDB #$7F ; Clear high bit from dictionary.
	1103	+14C9 E1A0 (fig-forth-auto680):01100 CMPB ,Y+ ; Compare "last" characters.
	1104	+ (fig-forth-auto680):01101 * LBSR DBGREG
	1105	+14CB 2717 (fig-forth-auto680):01102 BEQ FOUND ; Matches even if dictionary actual length is shorter.
	1106	+14CD AE81 (fig-forth-auto680):01103 PFNDLN LDX ,X++ ; Get previous link in vocabulary.
	1107	+ (fig-forth-auto680):01104 * LBSR DBGREG
	1108	+14CF 26E4 (fig-forth-auto680):01105 BNE PFNDLP ; Continue if link not=0
	1109	+ (fig-forth-auto680):01106 *
	1110	+ (fig-forth-auto680):01107 * not found :
	1111	+14D1 3342 (fig-forth-auto680):01108 LEAU NATWID,U ; Return only false flag.
	1112	+14D3 CC0000 (fig-forth-auto680):01109 LDD #0
	1113	+14D6 EDC4 (fig-forth-auto680):01110 STD ,U
	1114	+ (fig-forth-auto680):01111 * LBSR DBGREG
	1115	+ (fig-forth-auto680):01112 * DEC <TRACEM
	1116	+14D8 35A0 (fig-forth-auto680):01113 PULS Y,PC
	1117	+ (fig-forth-auto680):01114 *
	1118	+14DA E1A0 (fig-forth-auto680):01115 PFNDCH CMPB ,Y+ ; Compare characters.
	1119	+ (fig-forth-auto680):01116 * LBSR DBGREG
	1120	+14DC 27E4 (fig-forth-auto680):01117 BEQ PFNDBR
	1121	+14DE (fig-forth-auto680):01118 PFNDUN
	1122	+14DE E680 (fig-forth-auto680):01119 PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
	1123	+ (fig-forth-auto680):01120 * LBSR DBGREG
	1124	+14E0 2AFC (fig-forth-auto680):01121 BPL PFNDSC
	1125	+ (fig-forth-auto680):01122 * LBSR DBGREG
	1126	+14E2 20E9 (fig-forth-auto680):01123 BRA PFNDLN
	1127	+ (fig-forth-auto680):01124 *
	1128	+ (fig-forth-auto680):01125 * found :
	1129	+ (fig-forth-auto680):01126 *
	1130	+14E4 3004 (fig-forth-auto680):01127 FOUND LEAX 2*NATWID,X
	1131	+ (fig-forth-auto680):01128 * LBSR DBGREG
	1132	+14E6 AF42 (fig-forth-auto680):01129 STX NATWID,U
	1133	+14E8 1F89 (fig-forth-auto680):01130 TFR A,B
	1134	+14EA 4F (fig-forth-auto680):01131 CLRA
	1135	+14EB EDC4 (fig-forth-auto680):01132 STD ,U
	1136	+ (fig-forth-auto680):01133 * LBSR DBGREG
	1137	+14ED C601 (fig-forth-auto680):01134 LDB #1
	1138	+14EF 3606 (fig-forth-auto680):01135 PSHU A,B
	1139	+ (fig-forth-auto680):01136 * LBSR DBGREG
	1140	+ (fig-forth-auto680):01137 * DEC <TRACEM
	1141	+14F1 35A0 (fig-forth-auto680):01138 PULS Y,PC
	1142	+ (fig-forth-auto680):01139 *
	1143	+ (fig-forth-auto680):01140 * 6800 model:
	1144	+ (fig-forth-auto680):01141 * NOP ; Probably leftovers from a debugging session.
	1145	+ (fig-forth-auto680):01142 * NOP
	1146	+ (fig-forth-auto680):01143 * PD EQU N ptr to dict word being checked
	1147	+ (fig-forth-auto680):01144 * PA0 EQU N+2
	1148	+ (fig-forth-auto680):01145 * PA EQU N+4
	1149	+ (fig-forth-auto680):01146 * PC EQU N+6
	1150	+ (fig-forth-auto680):01147 * LDX #PD
	1151	+ (fig-forth-auto680):01148 * LDB #4
	1152	+ (fig-forth-auto680):01149 * PFIND0 PULS A ; loop to get arguments
	1153	+ (fig-forth-auto680):01150 * STA 0,X
	1154	+ (fig-forth-auto680):01151 * LEAX 1,X ;
	1155	+ (fig-forth-auto680):01152 * DECB ;
	1156	+ (fig-forth-auto680):01153 * BNE PFIND0
	1157	+ (fig-forth-auto680):01154 *
	1158	+ (fig-forth-auto680):01155 * LDX PD
	1159	+ (fig-forth-auto680):01156 * PFNDLP LDB 0,X get count dict count
	1160	+ (fig-forth-auto680):01157 * STB PC
	1161	+ (fig-forth-auto680):01158 * ANDB #$3F
	1162	+ (fig-forth-auto680):01159 * LEAX 1,X ;
	1163	+ (fig-forth-auto680):01160 * STX PD update PD
	1164	+ (fig-forth-auto680):01161 * LDX PA0
	1165	+ (fig-forth-auto680):01162 * LDA 0,X get count from arg
	1166	+ (fig-forth-auto680):01163 * LEAX 1,X ;
	1167	+ (fig-forth-auto680):01164 * STX PA intialize PA
	1168	+ (fig-forth-auto680):01165 * PSHS B ; ** emulating CBA:
	1169	+ (fig-forth-auto680):01166 * CMPA ,S+ ; compare lengths
	1170	+ (fig-forth-auto680):01167 * BNE PFNDUN
	1171	+ (fig-forth-auto680):01168 * PFNDBR LDX PA
	1172	+ (fig-forth-auto680):01169 * LDA 0,X
	1173	+ (fig-forth-auto680):01170 * LEAX 1,X ;
	1174	+ (fig-forth-auto680):01171 * STX PA
	1175	+ (fig-forth-auto680):01172 * LDX PD
	1176	+ (fig-forth-auto680):01173 * LDB 0,X
	1177	+ (fig-forth-auto680):01174 * LEAX 1,X ;
	1178	+ (fig-forth-auto680):01175 * STX PD
	1179	+ (fig-forth-auto680):01176 * TSTB ; is dict entry neg. ?
	1180	+ (fig-forth-auto680):01177 * BPL PFNDCH
	1181	+ (fig-forth-auto680):01178 * ANDB #$7F clear sign
	1182	+ (fig-forth-auto680):01179 * PSHS B ; ** emulating CBA:
	1183	+ (fig-forth-auto680):01180 * CMPA ,S+ ;
	1184	+ (fig-forth-auto680):01181 * BEQ FOUND
	1185	+ (fig-forth-auto680):01182 * PFNDLN LDX 0,X get new link
	1186	+ (fig-forth-auto680):01183 * BNE PFNDLP continue if link not=0
	1187	+ (fig-forth-auto680):01184 *
	1188	+ (fig-forth-auto680):01185 * not found :
	1189	+ (fig-forth-auto680):01186 *
	1190	+ (fig-forth-auto680):01187 * CLRA ;
	1191	+ (fig-forth-auto680):01188 * CLRB ;
	1192	+ (fig-forth-auto680):01189 * JMP PUSHBA
	1193	+ (fig-forth-auto680):01190 * PFNDCH PSHS B ; ** emulating CBA:
	1194	+ (fig-forth-auto680):01191 * CMPA ,S+ ;
	1195	+ (fig-forth-auto680):01192 * BEQ PFNDBR
	1196	+ (fig-forth-auto680):01193 * PFNDUN LDX PD
	1197	+ (fig-forth-auto680):01194 * PFNDSC LDB 0,X scan forward to end of this name
	1198	+ (fig-forth-auto680):01195 * LEAX 1,X ;
	1199	+ (fig-forth-auto680):01196 * BPL PFNDSC
	1200	+ (fig-forth-auto680):01197 * BRA PFNDLN
	1201	+ (fig-forth-auto680):01198 *
	1202	+ (fig-forth-auto680):01199 * found :
	1203	+ (fig-forth-auto680):01200 *
	1204	+ (fig-forth-auto680):01201 * FOUND LDA PD compute CFA
	1205	+ (fig-forth-auto680):01202 * LDB PD+1
	1206	+ (fig-forth-auto680):01203 * ADDB #4
	1207	+ (fig-forth-auto680):01204 * ADCA #0
	1208	+ (fig-forth-auto680):01205 * PSHS B ;
	1209	+ (fig-forth-auto680):01206 * PSHS A ;
	1210	+ (fig-forth-auto680):01207 * LDA PC
	1211	+ (fig-forth-auto680):01208 * PSHS A ;
	1212	+ (fig-forth-auto680):01209 * CLRA ;
	1213	+ (fig-forth-auto680):01210 * PSHS A ;
	1214	+ (fig-forth-auto680):01211 * LDB #1
	1215	+ (fig-forth-auto680):01212 * JMP PUSHBA
	1216	+ (fig-forth-auto680):01213 *
	1217	+ (fig-forth-auto680):01214 * PSHS A ; Left over from a stray copy-paste, I guess.
	1218	+ (fig-forth-auto680):01215 * CLRA ;
	1219	+ (fig-forth-auto680):01216 * PSHS A ;
	1220	+ (fig-forth-auto680):01217 * LDB #1
	1221	+ (fig-forth-auto680):01218 * JMP PUSHBA
	1222	+ (fig-forth-auto680):01219 *
	1223	+ (fig-forth-auto680):01220 * ######>> screen 20 <<
	1224	+ (fig-forth-auto680):01221 * ======>> 12 <<
	1225	+ (fig-forth-auto680):01222 * ( buffer ch --- buffer symboloffset delimiteroffset scancount )
	1226	+ (fig-forth-auto680):01223 * ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
	1227	+ (fig-forth-auto680):01224 * ( buffer ch --- buffer nuloffset onepast scancount )
	1228	+ (fig-forth-auto680):01225 * Scan buffer for a symbol delimited by ch or ASCII NUL,
	1229	+ (fig-forth-auto680):01226 * return the length of the buffer region scanned,
	1230	+ (fig-forth-auto680):01227 * the offset to the trailing delimiter,
	1231	+ (fig-forth-auto680):01228 * and the offset of the first character of the symbol.
	1232	+ (fig-forth-auto680):01229 * Leave the buffer on the stack.
	1233	+ (fig-forth-auto680):01230 * Scancount is also offset to first character not yet looked at.
	1234	+ (fig-forth-auto680):01231 * If no symbol in buffer, scancount and symboloffset point to NUL
	1235	+ (fig-forth-auto680):01232 * and delimiteroffset points one beyond for some reason.
	1236	+ (fig-forth-auto680):01233 * On trailing NUL, delimiteroffset == scancount.
	1237	+ (fig-forth-auto680):01234 * (Buffer is the address of the buffer array to scan.)
	1238	+ (fig-forth-auto680):01235 * (This is a bit too tricky, really.)
	1239	+14F3 87 (fig-forth-auto680):01236 FCB $87
	1240	+14F4 454E434C4F53 (fig-forth-auto680):01237 FCC 'ENCLOS' ; 'ENCLOSE'
	1241	+14FA C5 (fig-forth-auto680):01238 FCB $C5
	1242	+14FB 14A6 (fig-forth-auto680):01239 FDB PFIND-9
	1243	+14FD 14FF (fig-forth-auto680):01240 ENCLOS FDB *+NATWID
	1244	+14FF A641 (fig-forth-auto680):01241 LDA 1,U ; Delimiter character to match against in A.
	1245	+1501 AE42 (fig-forth-auto680):01242 LDX NATWID,U ; Buffer to scan in.
	1246	+1503 5F (fig-forth-auto680):01243 CLRB ; Initialize offset. (Buffer < 256 wide!)
	1247	+ (fig-forth-auto680):01244 * Scan to a non-delimiter or a NUL
	1248	+1504 6D85 (fig-forth-auto680):01245 ENCDEL TST B,X ; NUL ?
	1249	+1506 271F (fig-forth-auto680):01246 BEQ ENCNUL
	1250	+1508 A185 (fig-forth-auto680):01247 CMPA B,X ; Delimiter?
	1251	+150A 2603 (fig-forth-auto680):01248 BNE ENC1ST
	1252	+150C 5C (fig-forth-auto680):01249 INCB ; count character
	1253	+150D 20F5 (fig-forth-auto680):01250 BRA ENCDEL
	1254	+ (fig-forth-auto680):01251 * Found first character. Save the offset.
	1255	+150F E741 (fig-forth-auto680):01252 ENC1ST STB 1,U ; Found first non-delimiter character --
	1256	+1511 6FC4 (fig-forth-auto680):01253 CLR ,U ; store the count, zero high byte.
	1257	+ (fig-forth-auto680):01254 * Scan to a delimiter or a NUL
	1258	+1513 6D85 (fig-forth-auto680):01255 ENCSYM TST B,X ; NUL ?
	1259	+1515 271E (fig-forth-auto680):01256 BEQ ENC0TR
	1260	+1517 A185 (fig-forth-auto680):01257 CMPA B,X ; delimiter?
	1261	+1519 2703 (fig-forth-auto680):01258 BEQ ENCEND
	1262	+151B 5C (fig-forth-auto680):01259 INCB
	1263	+151C 20F5 (fig-forth-auto680):01260 BRA ENCSYM
	1264	+ (fig-forth-auto680):01261 * Found end of symbol. Push offset to delimiter found.
	1265	+151E 4F (fig-forth-auto680):01262 ENCEND CLRA ; high byte -- buffer < 255 wide!
	1266	+151F 3606 (fig-forth-auto680):01263 PSHU A,B ; Offset to seen delimiter.
	1267	+ (fig-forth-auto680):01264 * Advance and push address of next character to check.
	1268	+1521 C30001 (fig-forth-auto680):01265 ADDD #1 ; In case offset was 255.
	1269	+1524 3606 (fig-forth-auto680):01266 PSHU A,B
	1270	+1526 39 (fig-forth-auto680):01267 RTS
	1271	+ (fig-forth-auto680):01268 * Found NUL before non-delimiter, therefore there is no word
	1272	+1527 4F (fig-forth-auto680):01269 ENCNUL CLRA ; high byte -- buffer < 255 wide!
	1273	+1528 EDC4 (fig-forth-auto680):01270 STD ,U ; offset to NUL.
	1274	+152A C30001 (fig-forth-auto680):01271 ADDD #1 ; Point after NUL to allow (FIND) to match it.
	1275	+152D 3606 (fig-forth-auto680):01272 PSHU A,B ;
	1276	+152F 830001 (fig-forth-auto680):01273 SUBD #1 ; Next is not passed NUL.
	1277	+1532 3606 (fig-forth-auto680):01274 PSHU A,B ; Stealing code will save only one byte.
	1278	+1534 39 (fig-forth-auto680):01275 RTS
	1279	+ (fig-forth-auto680):01276 * Found NUL following the word instead of delimiter.
	1280	+1535 (fig-forth-auto680):01277 ENC0TR
	1281	+ (fig-forth-auto680):01278 * INC <TRACEM
	1282	+ (fig-forth-auto680):01279 * LBSR DBGREG
	1283	+1535 4F (fig-forth-auto680):01280 CLRA
	1284	+1536 3606 (fig-forth-auto680):01281 PSHU A,B ; Save offset to first after symbol (NUL)
	1285	+ (fig-forth-auto680):01282 * LBSR DBGREG
	1286	+1538 3606 (fig-forth-auto680):01283 PSHU A,B ; and count scanned.
	1287	+ (fig-forth-auto680):01284 * LBSR DBGREG
	1288	+ (fig-forth-auto680):01285 * DEC <TRACEM
	1289	+153A 39 (fig-forth-auto680):01286 RTS
	1290	+ (fig-forth-auto680):01287 * NOTE :
	1291	+ (fig-forth-auto680):01288 * FC means offset (bytes) to First Character of next word
	1292	+ (fig-forth-auto680):01289 * EW " " to End of Word
	1293	+ (fig-forth-auto680):01290 * NC " " to Next Character to start next enclose at
	1294	+ (fig-forth-auto680):01291 * ENCLOS FDB *+NATWID
	1295	+ (fig-forth-auto680):01292 * LEAS 1,S ;
	1296	+ (fig-forth-auto680):01293 * PULS B ; now, get the low byte, for an 8-bit delimiter
	1297	+ (fig-forth-auto680):01294 * TFR S,X ; TSX :
	1298	+ (fig-forth-auto680):01295 * LDX 0,X
	1299	+ (fig-forth-auto680):01296 * CLR N
	1300	+ (fig-forth-auto680):01297 * * wait for a non-delimiter or a NUL
	1301	+ (fig-forth-auto680):01298 * ENCDEL LDA 0,X
	1302	+ (fig-forth-auto680):01299 * BEQ ENCNUL
	1303	+ (fig-forth-auto680):01300 * PSHS B ; ** emulating CBA:
	1304	+ (fig-forth-auto680):01301 * CMPA ,S+ ; CHECK FOR DELIM
	1305	+ (fig-forth-auto680):01302 * BNE ENC1ST
	1306	+ (fig-forth-auto680):01303 * LEAX 1,X ;
	1307	+ (fig-forth-auto680):01304 * INC N
	1308	+ (fig-forth-auto680):01305 * BRA ENCDEL
	1309	+ (fig-forth-auto680):01306 * * found first character. Push FC
	1310	+ (fig-forth-auto680):01307 * ENC1ST LDA N found first char.
	1311	+ (fig-forth-auto680):01308 * PSHS A ;
	1312	+ (fig-forth-auto680):01309 * CLRA ;
	1313	+ (fig-forth-auto680):01310 * PSHS A ;
	1314	+ (fig-forth-auto680):01311 * wait for a delimiter or a NUL
	1315	+ (fig-forth-auto680):01312 * ENCSYM LDA 0,X
	1316	+ (fig-forth-auto680):01313 * BEQ ENC0TR
	1317	+ (fig-forth-auto680):01314 * PSHS B ; ** emulating CBA:
	1318	+ (fig-forth-auto680):01315 * CMPA ,S+ ; ckech for delim.
	1319	+ (fig-forth-auto680):01316 * BEQ ENCEND
	1320	+ (fig-forth-auto680):01317 * LEAX 1,X ;
	1321	+ (fig-forth-auto680):01318 * INC N
	1322	+ (fig-forth-auto680):01319 * BRA ENCSYM
	1323	+ (fig-forth-auto680):01320 * * found EW. Push it
	1324	+ (fig-forth-auto680):01321 * ENCEND LDB N
	1325	+ (fig-forth-auto680):01322 * CLRA ;
	1326	+ (fig-forth-auto680):01323 * PSHS B ;
	1327	+ (fig-forth-auto680):01324 * PSHS A ;
	1328	+ (fig-forth-auto680):01325 * * advance and push NC
	1329	+ (fig-forth-auto680):01326 * INCB ;
	1330	+ (fig-forth-auto680):01327 * JMP PUSHBA
	1331	+ (fig-forth-auto680):01328 * found NUL before non-delimiter, therefore there is no word
	1332	+ (fig-forth-auto680):01329 * ENCNUL LDB N found NUL
	1333	+ (fig-forth-auto680):01330 * PSHS B ;
	1334	+ (fig-forth-auto680):01331 * PSHS A ;
	1335	+ (fig-forth-auto680):01332 * INCB ;
	1336	+ (fig-forth-auto680):01333 * BRA ENC0TR+2 ; ******** POTENTIAL BUG HERE *****
	1337	+ (fig-forth-auto680):01334 * ****** Should use labels in case opcodes change! ******
	1338	+ (fig-forth-auto680):01335 * found NUL following the word instead of SPACE
	1339	+ (fig-forth-auto680):01336 * ENC0TR LDB N
	1340	+ (fig-forth-auto680):01337 * PSHS B ; save EW
	1341	+ (fig-forth-auto680):01338 * PSHS A ;
	1342	+ (fig-forth-auto680):01339 * ENCL8 LDB N save NC
	1343	+ (fig-forth-auto680):01340 * JMP PUSHBA
	1344	+ (fig-forth-auto680):01341
	1345	+ (fig-forth-auto680):01342 PAGE
	1346	+ (fig-forth-auto680):01343 *
	1347	+ (fig-forth-auto680):01344 * ######>> screen 21 <<
	1348	+ (fig-forth-auto680):01345 * The next 4 words call system dependant I/O routines
	1349	+ (fig-forth-auto680):01346 * which are listed after word "-->" ( lable: "arrow" )
	1350	+ (fig-forth-auto680):01347 * in the dictionary.
	1351	+ (fig-forth-auto680):01348 *
	1352	+ (fig-forth-auto680):01349 * ======>> 13 <<
	1353	+ (fig-forth-auto680):01350 * ( c --- )
	1354	+ (fig-forth-auto680):01351 * Write c to the output device (screen or printer).
	1355	+ (fig-forth-auto680):01352 * ROM Uses the ECB device number at address $6F,
	1356	+ (fig-forth-auto680):01353 * -2 is printer, 0 is screen.
	1357	+153B 84 (fig-forth-auto680):01354 FCB $84
	1358	+153C 454D49 (fig-forth-auto680):01355 FCC 'EMI' ; 'EMIT'
	1359	+153F D4 (fig-forth-auto680):01356 FCB $D4
	1360	+1540 14F3 (fig-forth-auto680):01357 FDB ENCLOS-10
	1361	+1542 1544 (fig-forth-auto680):01358 EMIT FDB *+NATWID
	1362	+1544 3706 (fig-forth-auto680):01359 PULU D
	1363	+1546 171067 (fig-forth-auto680):01360 LBSR PEMIT ; PEMIT expects the character in D.
	1364	+1549 0C33 (fig-forth-auto680):01361 INC <XOUT+1
	1365	+154B 2602 (fig-forth-auto680):01362 BNE EMITDN
	1366	+154D 0C32 (fig-forth-auto680):01363 INC <XOUT
	1367	+154F 39 (fig-forth-auto680):01364 EMITDN RTS
	1368	+ (fig-forth-auto680):01365 * PULS A ;
	1369	+ (fig-forth-auto680):01366 * PULS A ;
	1370	+ (fig-forth-auto680):01367 * JSR PEMIT
	1371	+ (fig-forth-auto680):01368 * LDX UP
	1372	+ (fig-forth-auto680):01369 * INC XOUT+1-UORIG,X
	1373	+ (fig-forth-auto680):01370 * BNE *+4 ;
	1374	+ (fig-forth-auto680):01371 * **WARNING** HARD OFFSET: +4 ***
	1375	+ (fig-forth-auto680):01372 * INC XOUT-UORIG,X
	1376	+ (fig-forth-auto680):01373 * JMP NEXT
	1377	+ (fig-forth-auto680):01374 *
	1378	+ (fig-forth-auto680):01375 * ======>> 14 <<
	1379	+ (fig-forth-auto680):01376 * ( --- c )
	1380	+ (fig-forth-auto680):01377 * ( --- BREAK )
	1381	+ (fig-forth-auto680):01378 * Wait for a key from the keyboard.
	1382	+ (fig-forth-auto680):01379 * If the key is BREAK, set the high byte (result $FF03).
	1383	+1550 83 (fig-forth-auto680):01380 FCB $83
	1384	+1551 4B45 (fig-forth-auto680):01381 FCC 'KE' ; 'KEY'
	1385	+1553 D9 (fig-forth-auto680):01382 FCB $D9
	1386	+1554 153B (fig-forth-auto680):01383 FDB EMIT-7
	1387	+1556 1558 (fig-forth-auto680):01384 KEY FDB *+NATWID
	1388	+1558 171062 (fig-forth-auto680):01385 LBSR PKEY ; PKEY leaves the key/break code in D.
	1389	+155B 3606 (fig-forth-auto680):01386 PSHU D
	1390	+155D 39 (fig-forth-auto680):01387 RTS
	1391	+ (fig-forth-auto680):01388 * JSR PKEY
	1392	+ (fig-forth-auto680):01389 * PSHS A ;
	1393	+ (fig-forth-auto680):01390 * CLRA ;
	1394	+ (fig-forth-auto680):01391 * PSHS A ;
	1395	+ (fig-forth-auto680):01392 * JMP NEXT
	1396	+ (fig-forth-auto680):01393 *
	1397	+ (fig-forth-auto680):01394 * ======>> 15 <<
	1398	+ (fig-forth-auto680):01395 * ( --- f )
	1399	+ (fig-forth-auto680):01396 * Scan keyboard, but do not wait.
	1400	+ (fig-forth-auto680):01397 * Return 0 if no key,
	1401	+ (fig-forth-auto680):01398 * BREAK ($ff03) if BREAK is pressed,
	1402	+ (fig-forth-auto680):01399 * or key currently pressed.
	1403	+155E 89 (fig-forth-auto680):01400 FCB $89
	1404	+155F 3F5445524D494E41 (fig-forth-auto680):01401 FCC '?TERMINA' ; '?TERMINAL'
	1405	+1567 CC (fig-forth-auto680):01402 FCB $CC
	1406	+1568 1550 (fig-forth-auto680):01403 FDB KEY-6
	1407	+156A 156C (fig-forth-auto680):01404 QTERM FDB *+NATWID
	1408	+156C 171073 (fig-forth-auto680):01405 LBSR PQTER ; PQTER leaves the flag/key in D.
	1409	+156F 3606 (fig-forth-auto680):01406 PSHU D
	1410	+1571 39 (fig-forth-auto680):01407 RTS
	1411	+ (fig-forth-auto680):01408 * JSR PQTER
	1412	+ (fig-forth-auto680):01409 * CLRB ;
	1413	+ (fig-forth-auto680):01410 * JMP PUSHBA stack the flag
	1414	+ (fig-forth-auto680):01411 *
	1415	+ (fig-forth-auto680):01412 * ======>> 16 <<
	1416	+ (fig-forth-auto680):01413 * ( --- )
	1417	+ (fig-forth-auto680):01414 * EMIT a Carriage Return (ASCII CR).
	1418	+1572 82 (fig-forth-auto680):01415 FCB $82
	1419	+1573 43 (fig-forth-auto680):01416 FCC 'C' ; 'CR'
	1420	+1574 D2 (fig-forth-auto680):01417 FCB $D2
	1421	+1575 155E (fig-forth-auto680):01418 FDB QTERM-12
	1422	+1577 1579 (fig-forth-auto680):01419 CR FDB *+NATWID
	1423	+1579 161071 (fig-forth-auto680):01420 LBRA PCR ; Nothing really to do here.
	1424	+ (fig-forth-auto680):01421 * JSR PCR
	1425	+ (fig-forth-auto680):01422 * JMP NEXT
	1426	+ (fig-forth-auto680):01423 *
	1427	+ (fig-forth-auto680):01424 * ######>> screen 22 <<
	1428	+ (fig-forth-auto680):01425 * ======>> 17 <<
	1429	+ (fig-forth-auto680):01426 * ( source target count --- )
	1430	+ (fig-forth-auto680):01427 * Copy/move count bytes from source to target.
	1431	+ (fig-forth-auto680):01428 * Moves ascending addresses,
	1432	+ (fig-forth-auto680):01429 * so that overlapping only works if the source is above the destination.
	1433	+157C 85 (fig-forth-auto680):01430 FCB $85
	1434	+157D 434D4F56 (fig-forth-auto680):01431 FCC 'CMOV' ; 'CMOVE' : source, destination, count
	1435	+1581 C5 (fig-forth-auto680):01432 FCB $C5
	1436	+1582 1572 (fig-forth-auto680):01433 FDB CR-5
	1437	+1584 1586 (fig-forth-auto680):01434 CMOVE FDB *+NATWID
	1438	+1586 3420 (fig-forth-auto680):01435 PSHS Y ;
	1439	+ (fig-forth-auto680):01436 * INC <TRACEM
	1440	+ (fig-forth-auto680):01437 * LBSR DBGREG
	1441	+1588 AE42 (fig-forth-auto680):01438 LDX 1*NATWID,U
	1442	+158A 10AE44 (fig-forth-auto680):01439 LDY 2*NATWID,U
	1443	+158D 2004 (fig-forth-auto680):01440 BRA CMOVLE ;
	1444	+158F (fig-forth-auto680):01441 CMOVLP
	1445	+ (fig-forth-auto680):01442 * LBSR DBGREG
	1446	+158F A6A0 (fig-forth-auto680):01443 LDA ,Y+
	1447	+1591 A780 (fig-forth-auto680):01444 STA ,X+
	1448	+ (fig-forth-auto680):01445 * LBSR DBGREG
	1449	+1593 (fig-forth-auto680):01446 CMOVLE
	1450	+1593 ECC4 (fig-forth-auto680):01447 LDD ,U
	1451	+1595 830001 (fig-forth-auto680):01448 SUBD #1
	1452	+1598 EDC4 (fig-forth-auto680):01449 STD ,U
	1453	+159A 24F3 (fig-forth-auto680):01450 BCC CMOVLP
	1454	+159C 3346 (fig-forth-auto680):01451 LEAU 3*NATWID,U
	1455	+ (fig-forth-auto680):01452 * DEC <TRACEM
	1456	+159E 35A0 (fig-forth-auto680):01453 PULS Y,PC
	1457	+ (fig-forth-auto680):01454 * One way: ; takes ( 37+17count+9(count/256) cycles )
	1458	+ (fig-forth-auto680):01455 * PSHS Y ; #2~7 ; Gotta have our pointers.
	1459	+ (fig-forth-auto680):01456 * INC <TRACEM
	1460	+ (fig-forth-auto680):01457 * LBSR DBGREG
	1461	+ (fig-forth-auto680):01458 * PULU D,X,Y ; #2~11
	1462	+ (fig-forth-auto680):01459 * PSHS A ; #2~6 ; Gotta have our pointers.
	1463	+ (fig-forth-auto680):01460 * BRA CMOVLE ; #2~3
	1464	+ (fig-forth-auto680):01461 * CMOVLP
	1465	+ (fig-forth-auto680):01462 * LBSR DBGREG
	1466	+ (fig-forth-auto680):01463 * LDA ,Y+ ; #2~6
	1467	+ (fig-forth-auto680):01464 * STA ,X+ ; #2~6
	1468	+ (fig-forth-auto680):01465 * LBSR DBGREG
	1469	+ (fig-forth-auto680):01466 * CMOVLE
	1470	+ (fig-forth-auto680):01467 * SUBB #1 ; #2~2
	1471	+ (fig-forth-auto680):01468 * BCC CMOVLP ; #2~3
	1472	+ (fig-forth-auto680):01469 * DEC ,S ; #2=6
	1473	+ (fig-forth-auto680):01470 * BPL CMOVLP ; #2~3
	1474	+ (fig-forth-auto680):01471 * DEC <TRACEM
	1475	+ (fig-forth-auto680):01472 * PULS A,Y,PC ; #2~10
	1476	+ (fig-forth-auto680):01473 * Another way ; takes ( 42+17count+9(count/256) cycles )
	1477	+ (fig-forth-auto680):01474 * LDD #0 ; #3~3
	1478	+ (fig-forth-auto680):01475 * SUBD ,U++ ; #2~9 ; invert the count
	1479	+ (fig-forth-auto680):01476 * PSHS A,Y ; #2~8
	1480	+ (fig-forth-auto680):01477 * PULU X,Y ; #2~9
	1481	+ (fig-forth-auto680):01478 * BEQ CMOVEX ; #2~3
	1482	+ (fig-forth-auto680):01479 * CMOVEL
	1483	+ (fig-forth-auto680):01480 * LDA ,Y+ ; #2~6
	1484	+ (fig-forth-auto680):01481 * STA ,X+ ; #2~6
	1485	+ (fig-forth-auto680):01482 * INCB ; #1~2
	1486	+ (fig-forth-auto680):01483 * BNE CMOVEL ; #2~3
	1487	+ (fig-forth-auto680):01484 * INC ,S ; #2~6
	1488	+ (fig-forth-auto680):01485 * BNE CMOVEL ; #2~3
	1489	+ (fig-forth-auto680):01486 * CMOVEX
	1490	+ (fig-forth-auto680):01487 * PULS A,Y,PC ; #2~10
	1491	+ (fig-forth-auto680):01488 * Yet another way ; takes ( 37+29*count cycles )
	1492	+ (fig-forth-auto680):01489 * PSHS Y ; #2~7
	1493	+ (fig-forth-auto680):01490 * LDX NATWID,U ; #2~6
	1494	+ (fig-forth-auto680):01491 * LDY NATWID,U ; #3~7
	1495	+ (fig-forth-auto680):01492 * BRA CMOVLE ; #2~3
	1496	+ (fig-forth-auto680):01493 * CMOVLP
	1497	+ (fig-forth-auto680):01494 * LDA ,Y+ ; #2~6
	1498	+ (fig-forth-auto680):01495 * STA ,X+ ; #2~6
	1499	+ (fig-forth-auto680):01496 * CMOVLE
	1500	+ (fig-forth-auto680):01497 * LDD ,U ; #2~5
	1501	+ (fig-forth-auto680):01498 * SUBD #1 ; #3~4
	1502	+ (fig-forth-auto680):01499 * STD ,U ; #2~5
	1503	+ (fig-forth-auto680):01500 * BPL CMOVLP ; #2~3
	1504	+ (fig-forth-auto680):01501 * LEAU 3*NATWID,U ; #2~5
	1505	+ (fig-forth-auto680):01502 * PULS Y,PC ; #2~9
	1506	+ (fig-forth-auto680):01503 * Yet another way ; takes ( 44+24odd+33count/2 cycles )
	1507	+ (fig-forth-auto680):01504 * PSHS Y ; #2~7
	1508	+ (fig-forth-auto680):01505 * LDX NATWID,U ; #2~6
	1509	+ (fig-forth-auto680):01506 * LDY 2*NATWID,U ; #3~7
	1510	+ (fig-forth-auto680):01507 * LDD ,U ; #2~5
	1511	+ (fig-forth-auto680):01508 * BITB #1 ; #2~2
	1512	+ (fig-forth-auto680):01509 * BEQ CMOVLE ; #2~3
	1513	+ (fig-forth-auto680):01510 * SUBD #1 ; #3~4
	1514	+ (fig-forth-auto680):01511 * STD ,U ; #2~5
	1515	+ (fig-forth-auto680):01512 * LDA ,Y+ ; #2~6
	1516	+ (fig-forth-auto680):01513 * STA ,X+ ; #2~6
	1517	+ (fig-forth-auto680):01514 * BRA CMOVLE ; #2~3
	1518	+ (fig-forth-auto680):01515 * CMOVLP
	1519	+ (fig-forth-auto680):01516 * LDD ,Y++ ; #2~8
	1520	+ (fig-forth-auto680):01517 * STD ,X++ ; #2~8
	1521	+ (fig-forth-auto680):01518 * CMOVLI
	1522	+ (fig-forth-auto680):01519 * LDD ,U ; #2~5
	1523	+ (fig-forth-auto680):01520 * CMOVLE
	1524	+ (fig-forth-auto680):01521 * SUBD #2 ; #3~4
	1525	+ (fig-forth-auto680):01522 * STD ,U ; #2~5
	1526	+ (fig-forth-auto680):01523 * BPL CMOVLP ; #2~3
	1527	+ (fig-forth-auto680):01524 * LEAU 3*NATWID,U ; #2~5
	1528	+ (fig-forth-auto680):01525 * PULS Y,PC ; #2~9
	1529	+ (fig-forth-auto680):01526 * From the 6800 model:
	1530	+ (fig-forth-auto680):01527 * CMOVE FDB +2 takes ( 43+47count cycles ) on 6800
	1531	+ (fig-forth-auto680):01528 * LDX #N
	1532	+ (fig-forth-auto680):01529 * LDB #6
	1533	+ (fig-forth-auto680):01530 * CMOV1 PULS A ;
	1534	+ (fig-forth-auto680):01531 * STA 0,X move parameters to scratch area
	1535	+ (fig-forth-auto680):01532 * LEAX 1,X ;
	1536	+ (fig-forth-auto680):01533 * DECB ;
	1537	+ (fig-forth-auto680):01534 * BNE CMOV1
	1538	+ (fig-forth-auto680):01535 * CMOV2 LDA N
	1539	+ (fig-forth-auto680):01536 * LDB N+1
	1540	+ (fig-forth-auto680):01537 * SUBB #1
	1541	+ (fig-forth-auto680):01538 * SBCA #0
	1542	+ (fig-forth-auto680):01539 * STA N
	1543	+ (fig-forth-auto680):01540 * STB N+1
	1544	+ (fig-forth-auto680):01541 * BCS CMOV3
	1545	+ (fig-forth-auto680):01542 * LDX N+4
	1546	+ (fig-forth-auto680):01543 * LDA 0,X
	1547	+ (fig-forth-auto680):01544 * LEAX 1,X ;
	1548	+ (fig-forth-auto680):01545 * STX N+4
	1549	+ (fig-forth-auto680):01546 * LDX N+2
	1550	+ (fig-forth-auto680):01547 * STA 0,X
	1551	+ (fig-forth-auto680):01548 * LEAX 1,X ;
	1552	+ (fig-forth-auto680):01549 * STX N+2
	1553	+ (fig-forth-auto680):01550 * BRA CMOV2
	1554	+ (fig-forth-auto680):01551 * CMOV3 JMP NEXT
	1555	+ (fig-forth-auto680):01552 *
	1556	+ (fig-forth-auto680):01553 * ######>> screen 23 <<
	1557	+ (fig-forth-auto680):01554 * ======>> 18 <<
	1558	+ (fig-forth-auto680):01555 * ( u1 u2 --- ud )
	1559	+ (fig-forth-auto680):01556 * Multiplies the top two unsigned integers,
	1560	+ (fig-forth-auto680):01557 * yielding a double integer product.
	1561	+15A0 82 (fig-forth-auto680):01558 FCB $82
	1562	+15A1 55 (fig-forth-auto680):01559 FCC 'U' ; 'U*'
	1563	+15A2 AA (fig-forth-auto680):01560 FCB $AA
	1564	+15A3 157C (fig-forth-auto680):01561 FDB CMOVE-8
	1565	+15A5 15A7 (fig-forth-auto680):01562 USTAR FDB *+NATWID
	1566	+15A7 335C (fig-forth-auto680):01563 LEAU -2*NATWID,U
	1567	+15A9 A645 (fig-forth-auto680):01564 LDA 2*NATWID+1,U ; least
	1568	+15AB E647 (fig-forth-auto680):01565 LDB 3*NATWID+1,U
	1569	+15AD 3D (fig-forth-auto680):01566 MUL
	1570	+15AE ED42 (fig-forth-auto680):01567 STD NATWID,U
	1571	+15B0 A644 (fig-forth-auto680):01568 LDA 2*NATWID,U ; most
	1572	+15B2 E646 (fig-forth-auto680):01569 LDB 3*NATWID,U
	1573	+15B4 3D (fig-forth-auto680):01570 MUL
	1574	+15B5 EDC4 (fig-forth-auto680):01571 STD ,U
	1575	+15B7 EC45 (fig-forth-auto680):01572 LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi)
	1576	+15B9 3D (fig-forth-auto680):01573 MUL
	1577	+15BA E341 (fig-forth-auto680):01574 ADDD 1,U
	1578	+15BC 2402 (fig-forth-auto680):01575 BCC USTAR3
	1579	+15BE 6CC4 (fig-forth-auto680):01576 INC ,U
	1580	+15C0 ED41 (fig-forth-auto680):01577 USTAR3 STD 1,U
	1581	+15C2 A644 (fig-forth-auto680):01578 LDA 2*NATWID,U ; second inner (u2 hi)
	1582	+15C4 E646 (fig-forth-auto680):01579 LDB 3*NATWID,U ; (u1 lo)
	1583	+15C6 3D (fig-forth-auto680):01580 MUL
	1584	+15C7 E341 (fig-forth-auto680):01581 ADDD 1,U
	1585	+15C9 2402 (fig-forth-auto680):01582 BCC USTAR4
	1586	+15CB 6CC4 (fig-forth-auto680):01583 INC ,U
	1587	+15CD ED41 (fig-forth-auto680):01584 USTAR4 STD 1,U
	1588	+15CF 3716 (fig-forth-auto680):01585 PULU D,X
	1589	+15D1 EDC4 (fig-forth-auto680):01586 STD ,U
	1590	+15D3 AF42 (fig-forth-auto680):01587 STX NATWID,U
	1591	+15D5 39 (fig-forth-auto680):01588 RTS
	1592	+ (fig-forth-auto680):01589 *
	1593	+ (fig-forth-auto680):01590 * from 6800 model:
	1594	+ (fig-forth-auto680):01591 * BSR USTARS
	1595	+ (fig-forth-auto680):01592 * LEAS 1,S ;
	1596	+ (fig-forth-auto680):01593 * LEAS 1,S ;
	1597	+ (fig-forth-auto680):01594 * JMP PUSHBA
	1598	+ (fig-forth-auto680):01595 *
	1599	+ (fig-forth-auto680):01596 * The following is a subroutine which
	1600	+ (fig-forth-auto680):01597 * multiplies top 2 words on stack,
	1601	+ (fig-forth-auto680):01598 * leaving 32-bit result: high order word in A,B
	1602	+ (fig-forth-auto680):01599 * low order word in 2nd word of stack.
	1603	+ (fig-forth-auto680):01600 *
	1604	+ (fig-forth-auto680):01601 * USTARS LDA #16 bits/word counter
	1605	+ (fig-forth-auto680):01602 * PSHS A ;
	1606	+ (fig-forth-auto680):01603 * CLRA ;
	1607	+ (fig-forth-auto680):01604 * CLRB ;
	1608	+ (fig-forth-auto680):01605 * TFR S,X ; TSX :
	1609	+ (fig-forth-auto680):01606 * USTAR2 ROR 5,X shift multiplier
	1610	+ (fig-forth-auto680):01607 * ROR 6,X
	1611	+ (fig-forth-auto680):01608 * DEC 0,X done?
	1612	+ (fig-forth-auto680):01609 * BMI USTAR4
	1613	+ (fig-forth-auto680):01610 * BCC USTAR3
	1614	+ (fig-forth-auto680):01611 * ADDB 4,X
	1615	+ (fig-forth-auto680):01612 * ADCA 3,X
	1616	+ (fig-forth-auto680):01613 * USTAR3 RORA ;
	1617	+ (fig-forth-auto680):01614 * RORB ; shift result
	1618	+ (fig-forth-auto680):01615 * BRA USTAR2
	1619	+ (fig-forth-auto680):01616 * USTAR4 LEAS 1,S ; dump counter
	1620	+ (fig-forth-auto680):01617 * RTS
	1621	+ (fig-forth-auto680):01618 *
	1622	+ (fig-forth-auto680):01619 * ######>> screen 24 <<
	1623	+ (fig-forth-auto680):01620 * ======>> 19 <<
	1624	+ (fig-forth-auto680):01621 * ( ud u --- uremainder uquotient )
	1625	+ (fig-forth-auto680):01622 * Divides the top unsigned integer
	1626	+ (fig-forth-auto680):01623 * into the second and third words on the stack
	1627	+ (fig-forth-auto680):01624 * as a single unsigned double integer,
	1628	+ (fig-forth-auto680):01625 * leaving the remainder and quotient (quotient on top)
	1629	+ (fig-forth-auto680):01626 * as unsigned integers.
	1630	+ (fig-forth-auto680):01627 *
	1631	+ (fig-forth-auto680):01628 * The smaller the divisor, the more likely dropping the high word
	1632	+ (fig-forth-auto680):01629 * of the quotient loses significant bits. See M/MOD .
	1633	+ (fig-forth-auto680):01630 *
	1634	+15D6 82 (fig-forth-auto680):01631 FCB $82
	1635	+15D7 55 (fig-forth-auto680):01632 FCC 'U' ; 'U/'
	1636	+15D8 AF (fig-forth-auto680):01633 FCB $AF
	1637	+15D9 15A0 (fig-forth-auto680):01634 FDB USTAR-5
	1638	+15DB 15DD (fig-forth-auto680):01635 USLASH FDB *+NATWID
	1639	+15DD 8611 (fig-forth-auto680):01636 LDA #17 ; bit ct
	1640	+15DF 3402 (fig-forth-auto680):01637 PSHS A
	1641	+15E1 EC42 (fig-forth-auto680):01638 LDD NATWID,U ; dividend
	1642	+15E3 10A3C4 (fig-forth-auto680):01639 USLDIV CMPD ,U ; divisor
	1643	+15E6 2404 (fig-forth-auto680):01640 BHS USLSUB
	1644	+15E8 1CFE (fig-forth-auto680):01641 ANDCC #~1 ; carry clear
	1645	+15EA 2004 (fig-forth-auto680):01642 BRA USLBIT
	1646	+15EC A3C4 (fig-forth-auto680):01643 USLSUB SUBD ,U
	1647	+15EE 1A01 (fig-forth-auto680):01644 ORCC #1 ; quotient, (carry set)
	1648	+15F0 6945 (fig-forth-auto680):01645 USLBIT ROL 2*NATWID+1,U ; save it
	1649	+15F2 6944 (fig-forth-auto680):01646 ROL 2*NATWID,U
	1650	+15F4 6AE4 (fig-forth-auto680):01647 DEC ,S ; more bits?
	1651	+15F6 2706 (fig-forth-auto680):01648 BEQ USLR
	1652	+15F8 59 (fig-forth-auto680):01649 ROLB ; remainder
	1653	+15F9 49 (fig-forth-auto680):01650 ROLA
	1654	+15FA 24E7 (fig-forth-auto680):01651 BCC USLDIV
	1655	+15FC 20EE (fig-forth-auto680):01652 BRA USLSUB
	1656	+15FE 3342 (fig-forth-auto680):01653 USLR LEAU NATWID,U
	1657	+1600 AE42 (fig-forth-auto680):01654 LDX NATWID,U
	1658	+1602 ED42 (fig-forth-auto680):01655 STD NATWID,U
	1659	+1604 AFC4 (fig-forth-auto680):01656 STX ,U
	1660	+1606 3582 (fig-forth-auto680):01657 PULS A,PC ; Avoiding a LEAS 1,S by discarding A.
	1661	+ (fig-forth-auto680):01658 *
	1662	+ (fig-forth-auto680):01659 * from 6800 model:
	1663	+ (fig-forth-auto680):01660 * LDA #17
	1664	+ (fig-forth-auto680):01661 * PSHS A ;
	1665	+ (fig-forth-auto680):01662 * TFR S,X ; TSX :
	1666	+ (fig-forth-auto680):01663 * LDA 3,X
	1667	+ (fig-forth-auto680):01664 * LDB 4,X
	1668	+ (fig-forth-auto680):01665 * USL1 CMPA 1,X
	1669	+ (fig-forth-auto680):01666 * BHI USL3
	1670	+ (fig-forth-auto680):01667 * BCS USL2
	1671	+ (fig-forth-auto680):01668 * CMPB 2,X
	1672	+ (fig-forth-auto680):01669 * BCC USL3
	1673	+ (fig-forth-auto680):01670 * USL2 ANDCC #~$01 ; CLC :
	1674	+ (fig-forth-auto680):01671 * BRA USL4
	1675	+ (fig-forth-auto680):01672 * USL3 SUBB 2,X
	1676	+ (fig-forth-auto680):01673 * SBCA 1,X
	1677	+ (fig-forth-auto680):01674 * ORCC #$01 ; SEC :
	1678	+ (fig-forth-auto680):01675 * USL4 ROL 6,X
	1679	+ (fig-forth-auto680):01676 * ROL 5,X
	1680	+ (fig-forth-auto680):01677 * DEC 0,X
	1681	+ (fig-forth-auto680):01678 * BEQ USL5
	1682	+ (fig-forth-auto680):01679 * ROLB ;
	1683	+ (fig-forth-auto680):01680 * ROLA ;
	1684	+ (fig-forth-auto680):01681 * BCC USL1
	1685	+ (fig-forth-auto680):01682 * BRA USL3
	1686	+ (fig-forth-auto680):01683 * USL5 LEAS 1,S ;
	1687	+ (fig-forth-auto680):01684 * LEAS 1,S ;
	1688	+ (fig-forth-auto680):01685 * LEAS 1,S ;
	1689	+ (fig-forth-auto680):01686 * LEAS 1,S ;
	1690	+ (fig-forth-auto680):01687 * LEAS 1,S ;
	1691	+ (fig-forth-auto680):01688 * JMP SWAP+4 reverse quotient & remainder
	1692	+ (fig-forth-auto680):01689 *
	1693	+ (fig-forth-auto680):01690 * ######>> screen 25 <<
	1694	+ (fig-forth-auto680):01691 * ======>> 20 <<
	1695	+ (fig-forth-auto680):01692 * ( n1 n2 --- n )
	1696	+ (fig-forth-auto680):01693 * Bitwise and the top two integers.
	1697	+1608 83 (fig-forth-auto680):01694 FCB $83
	1698	+1609 414E (fig-forth-auto680):01695 FCC 'AN' ; 'AND'
	1699	+160B C4 (fig-forth-auto680):01696 FCB $C4
	1700	+160C 15D6 (fig-forth-auto680):01697 FDB USLASH-5
	1701	+160E 1610 (fig-forth-auto680):01698 AND FDB *+NATWID
	1702	+1610 3706 (fig-forth-auto680):01699 PULU A,B
	1703	+1612 E441 (fig-forth-auto680):01700 ANDB 1,U
	1704	+1614 A4C4 (fig-forth-auto680):01701 ANDA ,U
	1705	+1616 EDC4 (fig-forth-auto680):01702 STD ,U
	1706	+1618 39 (fig-forth-auto680):01703 RTS
	1707	+ (fig-forth-auto680):01704 * PULS A ;
	1708	+ (fig-forth-auto680):01705 * PULS B ;
	1709	+ (fig-forth-auto680):01706 * TFR S,X ; TSX :
	1710	+ (fig-forth-auto680):01707 * ANDB 1,X
	1711	+ (fig-forth-auto680):01708 * ANDA 0,X
	1712	+ (fig-forth-auto680):01709 * JMP STABX
	1713	+ (fig-forth-auto680):01710 *
	1714	+ (fig-forth-auto680):01711 * ======>> 21 <<
	1715	+ (fig-forth-auto680):01712 * ( n1 n2 --- n )
	1716	+ (fig-forth-auto680):01713 * Bitwise or the top two integers.
	1717	+1619 82 (fig-forth-auto680):01714 FCB $82
	1718	+161A 4F (fig-forth-auto680):01715 FCC 'O' ; 'OR'
	1719	+161B D2 (fig-forth-auto680):01716 FCB $D2
	1720	+161C 1608 (fig-forth-auto680):01717 FDB AND-6
	1721	+161E 1620 (fig-forth-auto680):01718 OR FDB *+NATWID
	1722	+1620 3706 (fig-forth-auto680):01719 PULU A,B
	1723	+1622 EA41 (fig-forth-auto680):01720 ORB 1,U
	1724	+1624 AAC4 (fig-forth-auto680):01721 ORA ,U
	1725	+1626 EDC4 (fig-forth-auto680):01722 STD ,U
	1726	+1628 39 (fig-forth-auto680):01723 RTS
	1727	+ (fig-forth-auto680):01724 * PULS A ;
	1728	+ (fig-forth-auto680):01725 * PULS B ;
	1729	+ (fig-forth-auto680):01726 * TFR S,X ; TSX :
	1730	+ (fig-forth-auto680):01727 * ORB 1,X
	1731	+ (fig-forth-auto680):01728 * ORA 0,X
	1732	+ (fig-forth-auto680):01729 * JMP STABX
	1733	+ (fig-forth-auto680):01730 *
	1734	+ (fig-forth-auto680):01731 * ======>> 22 <<
	1735	+ (fig-forth-auto680):01732 * ( n1 n2 --- n )
	1736	+ (fig-forth-auto680):01733 * Bitwise exclusive or the top two integers.
	1737	+1629 83 (fig-forth-auto680):01734 FCB $83
	1738	+162A 584F (fig-forth-auto680):01735 FCC 'XO' ; 'XOR'
	1739	+162C D2 (fig-forth-auto680):01736 FCB $D2
	1740	+162D 1619 (fig-forth-auto680):01737 FDB OR-5
	1741	+162F 1631 (fig-forth-auto680):01738 XOR FDB *+NATWID
	1742	+1631 3706 (fig-forth-auto680):01739 PULU A,B
	1743	+1633 E841 (fig-forth-auto680):01740 EORB 1,U
	1744	+1635 A8C4 (fig-forth-auto680):01741 EORA ,U
	1745	+1637 EDC4 (fig-forth-auto680):01742 STD ,U
	1746	+1639 39 (fig-forth-auto680):01743 RTS
	1747	+ (fig-forth-auto680):01744 * PULS A ;
	1748	+ (fig-forth-auto680):01745 * PULS B ;
	1749	+ (fig-forth-auto680):01746 * TFR S,X ; TSX :
	1750	+ (fig-forth-auto680):01747 * EORB 1,X
	1751	+ (fig-forth-auto680):01748 * EORA 0,X
	1752	+ (fig-forth-auto680):01749 * JMP STABX
	1753	+ (fig-forth-auto680):01750 *
	1754	+ (fig-forth-auto680):01751 * ######>> screen 26 <<
	1755	+ (fig-forth-auto680):01752 * ======>> 23 <<
	1756	+ (fig-forth-auto680):01753 * ( --- adr )
	1757	+ (fig-forth-auto680):01754 * Fetch the parameter stack pointer (before it is pushed).
	1758	+ (fig-forth-auto680):01755 * This points at whatever was on the top of stack before.
	1759	+163A 83 (fig-forth-auto680):01756 FCB $83
	1760	+163B 5350 (fig-forth-auto680):01757 FCC 'SP' ; 'SP@'
	1761	+163D C0 (fig-forth-auto680):01758 FCB $C0
	1762	+163E 1629 (fig-forth-auto680):01759 FDB XOR-6
	1763	+1640 1642 (fig-forth-auto680):01760 SPAT FDB *+NATWID
	1764	+1642 1F31 (fig-forth-auto680):01761 TFR U,X
	1765	+1644 3610 (fig-forth-auto680):01762 PSHU X
	1766	+1646 39 (fig-forth-auto680):01763 RTS
	1767	+ (fig-forth-auto680):01764 * TFR S,X ; TSX :
	1768	+ (fig-forth-auto680):01765 * STX N scratch area
	1769	+ (fig-forth-auto680):01766 * LDX #N
	1770	+ (fig-forth-auto680):01767 * JMP GETX
	1771	+ (fig-forth-auto680):01768 *
	1772	+ (fig-forth-auto680):01769 * ======>> 24 <<
	1773	+ (fig-forth-auto680):01770 * ( whatever --- nothing )
	1774	+ (fig-forth-auto680):01771 * Initialize the parameter stack pointer from the USER variable S0.
	1775	+ (fig-forth-auto680):01772 * Effectively clears the stack.
	1776	+1647 83 (fig-forth-auto680):01773 FCB $83
	1777	+1648 5350 (fig-forth-auto680):01774 FCC 'SP' ; 'SP!'
	1778	+164A A1 (fig-forth-auto680):01775 FCB $A1
	1779	+164B 163A (fig-forth-auto680):01776 FDB SPAT-6
	1780	+164D 164F (fig-forth-auto680):01777 SPSTOR FDB *+NATWID
	1781	+164F DE1E (fig-forth-auto680):01778 LDU <XSPZER
	1782	+1651 39 (fig-forth-auto680):01779 RTS
	1783	+ (fig-forth-auto680):01780 * LDX UP
	1784	+ (fig-forth-auto680):01781 * LDX XSPZER-UORIG,X
	1785	+ (fig-forth-auto680):01782 * TFR X,S ; TXS : watch it ! X and S are not equal on 6800.
	1786	+ (fig-forth-auto680):01783 * JMP NEXT
	1787	+ (fig-forth-auto680):01784 * ======>> 25 <<
	1788	+ (fig-forth-auto680):01785 * ( whatever *** nothing )
	1789	+ (fig-forth-auto680):01786 * Initialize the return stack pointer from the initialization table
	1790	+ (fig-forth-auto680):01787 * instead of the user variable R0, for some reason.
	1791	+ (fig-forth-auto680):01788 * Quite possibly, this should be from R0.
	1792	+ (fig-forth-auto680):01789 * Effectively aborts all in process definitions, except the active one.
	1793	+ (fig-forth-auto680):01790 * An emergency measure, to be sure.
	1794	+ (fig-forth-auto680):01791 * The routine that calls this must never execute a return.
	1795	+ (fig-forth-auto680):01792 * So this should never be executed from the terminal, I guess.
	1796	+ (fig-forth-auto680):01793 * This is another that should be compile-time only, and in a separate vocabulary.
	1797	+1652 83 (fig-forth-auto680):01794 FCB $83
	1798	+1653 5250 (fig-forth-auto680):01795 FCC 'RP' ; 'RP!'
	1799	+1655 A1 (fig-forth-auto680):01796 FCB $A1
	1800	+1656 1647 (fig-forth-auto680):01797 FDB SPSTOR-6
	1801	+1658 165A (fig-forth-auto680):01798 RPSTOR FDB *+NATWID
	1802	+165A 3510 (fig-forth-auto680):01799 PULS X ; But this guy has to return to his caller.
	1803	+165C 10FE1214 (fig-forth-auto680):01800 LDS RINIT
	1804	+1660 6E84 (fig-forth-auto680):01801 JMP ,X
	1805	+ (fig-forth-auto680):01802 * LDX RINIT initialize from rom constant
	1806	+ (fig-forth-auto680):01803 * STX RP
	1807	+ (fig-forth-auto680):01804 * JMP NEXT
	1808	+ (fig-forth-auto680):01805 *
	1809	+ (fig-forth-auto680):01806 * ======>> 26 <<
	1810	+ (fig-forth-auto680):01807 * ( ip *** )
	1811	+ (fig-forth-auto680):01808 * Pop IP from return stack (return from high-level definition).
	1812	+ (fig-forth-auto680):01809 * Can be used in a screen to force interpretion to terminate.
	1813	+ (fig-forth-auto680):01810 * Must not be executed when temporaries are saved on top of the return stack.
	1814	+1662 82 (fig-forth-auto680):01811 FCB $82
	1815	+1663 3B (fig-forth-auto680):01812 FCC ';' ; ';S'
	1816	+1664 D3 (fig-forth-auto680):01813 FCB $D3
	1817	+1665 1652 (fig-forth-auto680):01814 FDB RPSTOR-6
	1818	+1667 1669 (fig-forth-auto680):01815 SEMIS FDB *+NATWID
	1819	+1669 3526 (fig-forth-auto680):01816 PULS D,Y ; return address in D, and saved IP in Y.
	1820	+166B 1F05 (fig-forth-auto680):01817 TFR D,PC ; Synthetic return.
	1821	+ (fig-forth-auto680):01818 *
	1822	+ (fig-forth-auto680):01819 * Form 6800 model:
	1823	+ (fig-forth-auto680):01820 * LDX RP
	1824	+ (fig-forth-auto680):01821 * LEAX 1,X ;
	1825	+ (fig-forth-auto680):01822 * LEAX 1,X ;
	1826	+ (fig-forth-auto680):01823 * STX RP
	1827	+ (fig-forth-auto680):01824 * LDX 0,X get address we have just finished.
	1828	+ (fig-forth-auto680):01825 * JMP NEXT+2 increment the return address & do next word
	1829	+ (fig-forth-auto680):01826 *
	1830	+ (fig-forth-auto680):01827 * ######>> screen 27 <<
	1831	+ (fig-forth-auto680):01828 * ======>> 27 <<
	1832	+ (fig-forth-auto680):01829 * ( limit index *** index index )
	1833	+ (fig-forth-auto680):01830 * Force the terminating condition for the innermost loop by
	1834	+ (fig-forth-auto680):01831 * copying its index to its limit.
	1835	+ (fig-forth-auto680):01832 * Termination is postponed until the next
	1836	+ (fig-forth-auto680):01833 * LOOP or +LOOP instruction is executed.
	1837	+ (fig-forth-auto680):01834 * The index remains available for use until
	1838	+ (fig-forth-auto680):01835 * the LOOP or +LOOP instruction is encountered.
	1839	+ (fig-forth-auto680):01836 * Note that the assumption is that the current count is the correct count
	1840	+ (fig-forth-auto680):01837 * to end at, rather than pushing the count to the final count.
	1841	+166D 85 (fig-forth-auto680):01838 FCB $85
	1842	+166E 4C454156 (fig-forth-auto680):01839 FCC 'LEAV' ; 'LEAVE'
	1843	+1672 C5 (fig-forth-auto680):01840 FCB $C5
	1844	+1673 1662 (fig-forth-auto680):01841 FDB SEMIS-5
	1845	+1675 1677 (fig-forth-auto680):01842 LEAVE FDB *+NATWID
	1846	+1677 EC62 (fig-forth-auto680):01843 LDD NATWID,S ; Dodge the return address.
	1847	+1679 ED64 (fig-forth-auto680):01844 STD 2*NATWID,S
	1848	+167B 39 (fig-forth-auto680):01845 RTS
	1849	+ (fig-forth-auto680):01846 * LDX RP
	1850	+ (fig-forth-auto680):01847 * LDA 2,X
	1851	+ (fig-forth-auto680):01848 * LDB 3,X
	1852	+ (fig-forth-auto680):01849 * STA 4,X
	1853	+ (fig-forth-auto680):01850 * STB 5,X
	1854	+ (fig-forth-auto680):01851 * JMP NEXT
	1855	+ (fig-forth-auto680):01852 *
	1856	+ (fig-forth-auto680):01853 * ======>> 28 <<
	1857	+ (fig-forth-auto680):01854 * ( n --- )
	1858	+ (fig-forth-auto680):01855 * ( *** n )
	1859	+ (fig-forth-auto680):01856 * Move top of parameter stack to top of return stack.
	1860	+167C 82 (fig-forth-auto680):01857 FCB $82
	1861	+167D 3E (fig-forth-auto680):01858 FCC '>' ; '>R'
	1862	+167E D2 (fig-forth-auto680):01859 FCB $D2
	1863	+167F 166D (fig-forth-auto680):01860 FDB LEAVE-8
	1864	+1681 1683 (fig-forth-auto680):01861 TOR FDB *+NATWID
	1865	+1683 3706 (fig-forth-auto680):01862 PULU A,B
	1866	+1685 AEE4 (fig-forth-auto680):01863 LDX ,S
	1867	+1687 EDE4 (fig-forth-auto680):01864 STD ,S ; Put it where the return address was.
	1868	+1689 6E84 (fig-forth-auto680):01865 JMP ,X
	1869	+ (fig-forth-auto680):01866 * LDX RP
	1870	+ (fig-forth-auto680):01867 * LEAX -1,X ;
	1871	+ (fig-forth-auto680):01868 * LEAX -1,X ;
	1872	+ (fig-forth-auto680):01869 * STX RP
	1873	+ (fig-forth-auto680):01870 * PULS A ;
	1874	+ (fig-forth-auto680):01871 * PULS B ;
	1875	+ (fig-forth-auto680):01872 * STA 2,X
	1876	+ (fig-forth-auto680):01873 * STB 3,X
	1877	+ (fig-forth-auto680):01874 * JMP NEXT
	1878	+ (fig-forth-auto680):01875 *
	1879	+ (fig-forth-auto680):01876 * ======>> 29 <<
	1880	+ (fig-forth-auto680):01877 * ( --- n )
	1881	+ (fig-forth-auto680):01878 * ( n *** )
	1882	+ (fig-forth-auto680):01879 * Move top of return stack to top of parameter stack.
	1883	+168B 82 (fig-forth-auto680):01880 FCB $82
	1884	+168C 52 (fig-forth-auto680):01881 FCC 'R' ; 'R>'
	1885	+168D BE (fig-forth-auto680):01882 FCB $BE
	1886	+168E 167C (fig-forth-auto680):01883 FDB TOR-5
	1887	+1690 1692 (fig-forth-auto680):01884 FROMR FDB *+NATWID
	1888	+1692 3516 (fig-forth-auto680):01885 PULS D,X
	1889	+1694 3610 (fig-forth-auto680):01886 PSHU X
	1890	+1696 1F05 (fig-forth-auto680):01887 TFR D,PC
	1891	+ (fig-forth-auto680):01888 * LDX RP
	1892	+ (fig-forth-auto680):01889 * LDA 2,X
	1893	+ (fig-forth-auto680):01890 * LDB 3,X
	1894	+ (fig-forth-auto680):01891 * LEAX 1,X ;
	1895	+ (fig-forth-auto680):01892 * LEAX 1,X ;
	1896	+ (fig-forth-auto680):01893 * STX RP
	1897	+ (fig-forth-auto680):01894 * JMP PUSHBA
	1898	+ (fig-forth-auto680):01895 *
	1899	+ (fig-forth-auto680):01896 * ======>> 30 <<
	1900	+ (fig-forth-auto680):01897 * ( --- n )
	1901	+ (fig-forth-auto680):01898 * ( n *** n )
	1902	+ (fig-forth-auto680):01899 * Copy the top of return stack to top of parameter stack.
	1903	+ (fig-forth-auto680):01900 * A synonym for I.
	1904	+1698 81 (fig-forth-auto680):01901 FCB $81 R
	1905	+1699 D2 (fig-forth-auto680):01902 FCB $D2
	1906	+169A 168B (fig-forth-auto680):01903 FDB FROMR-5
	1907	+169C 1467 (fig-forth-auto680):01904 R FDB I+NATWID
	1908	+ (fig-forth-auto680):01905
	1909	+ (fig-forth-auto680):01906 * LDX RP
	1910	+ (fig-forth-auto680):01907 * LEAX 1,X ;
	1911	+ (fig-forth-auto680):01908 * LEAX 1,X ;
	1912	+ (fig-forth-auto680):01909 * JMP GETX
	1913	+ (fig-forth-auto680):01910 *
	1914	+ (fig-forth-auto680):01911 * ######>> screen 28 <<
	1915	+ (fig-forth-auto680):01912 * ======>> 31 <<
	1916	+ (fig-forth-auto680):01913 * ( n --- n=0 )
	1917	+ (fig-forth-auto680):01914 * Logically invert top of stack;
	1918	+ (fig-forth-auto680):01915 * or flag true if top is zero, otherwise false.
	1919	+169E 82 (fig-forth-auto680):01916 FCB $82
	1920	+169F 30 (fig-forth-auto680):01917 FCC '0' ; '0='
	1921	+16A0 BD (fig-forth-auto680):01918 FCB $BD
	1922	+16A1 1698 (fig-forth-auto680):01919 FDB R-4
	1923	+16A3 16A5 (fig-forth-auto680):01920 ZEQU FDB *+NATWID
	1924	+16A5 CC0000 (fig-forth-auto680):01921 LDD #0
	1925	+16A8 AEC4 (fig-forth-auto680):01922 LDX ,U
	1926	+16AA 2601 (fig-forth-auto680):01923 BNE ZEQUF
	1927	+16AC 5C (fig-fo

Part of diff was cut off due to size limit. Use your local client to view the full diff.

Show on old repository browser

fig-forth-6809 Fork

fig-forth-6809: 提交

Commit MetaInfo

Log Message

Change Summary

差異

fig-forth-6809
Fork