(fig-forth-auto680):00001                 OPT PRT
                      (fig-forth-auto680):00002         
                      (fig-forth-auto680):00003         * fig-FORTH FOR 6809
                      (fig-forth-auto680):00004         * ASSEMBLY SOURCE LISTING
                      (fig-forth-auto680):00005         
                      (fig-forth-auto680):00006         * RELEASE 0
                      (fig-forth-auto680):00007         * JAN 2019
                      (fig-forth-auto680):00008         * WITH COMPILER SECURITY
                      (fig-forth-auto680):00009         * AND VARIABLE LENGTH NAMES
                      (fig-forth-auto680):00010         *
                      (fig-forth-auto680):00011         * Adapted by Joel Matthew Rees 
                      (fig-forth-auto680):00012         * from fig-FORTH for 6800 by Dave Lion, et. al.
                      (fig-forth-auto680):00013         
                      (fig-forth-auto680):00014         * This free/libre/open source publication is provided
                      (fig-forth-auto680):00015         * through the courtesy of:
                      (fig-forth-auto680):00016         * FORTH
                      (fig-forth-auto680):00017         * INTEREST
                      (fig-forth-auto680):00018         * GROUP
                      (fig-forth-auto680):00019         * fig
                      (fig-forth-auto680):00020         * and other interested parties.
                      (fig-forth-auto680):00021         
                      (fig-forth-auto680):00022         * Ancient address:
                      (fig-forth-auto680):00023         * P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
                      (fig-forth-auto680):00024         * URL: http://www.forth.org
                      (fig-forth-auto680):00025         * Further distribution must include this notice.
                      (fig-forth-auto680):00026                 PAGE
                      (fig-forth-auto680):00027                 NAM     Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
                      (fig-forth-auto680):00028                 OPT     NOG,PAG
                      (fig-forth-auto680):00029         * filename fig-forth-auto6809opt.asm
                      (fig-forth-auto680):00030         * === FORTH-6809 {date} {time}
                      (fig-forth-auto680):00031         
                      (fig-forth-auto680):00032         
                      (fig-forth-auto680):00033         * Permission is hereby granted, free of charge, to any person obtaining a copy
                      (fig-forth-auto680):00034         * of this software and associated documentation files (the "Software"), to deal
                      (fig-forth-auto680):00035         * in the Software without restriction, including without limitation the rights
                      (fig-forth-auto680):00036         * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
                      (fig-forth-auto680):00037         * copies of the Software, and to permit persons to whom the Software is
                      (fig-forth-auto680):00038         * furnished to do so, subject to the following conditions:
                      (fig-forth-auto680):00039         *
                      (fig-forth-auto680):00040         * The above copyright notice and this permission notice shall be included in
                      (fig-forth-auto680):00041         * all copies or substantial portions of the Software.
                      (fig-forth-auto680):00042         
                      (fig-forth-auto680):00043         * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
                      (fig-forth-auto680):00044         * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
                      (fig-forth-auto680):00045         * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
                      (fig-forth-auto680):00046         * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
                      (fig-forth-auto680):00047         * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
                      (fig-forth-auto680):00048         * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
                      (fig-forth-auto680):00049         * THE SOFTWARE.
                      (fig-forth-auto680):00050         *
                      (fig-forth-auto680):00051         * "Associated documentation" for this declaration of license
                      (fig-forth-auto680):00052         * shall be interpreted to include only the comments in this file,
                      (fig-forth-auto680):00053         * or, if the code is split into multiple files,
                      (fig-forth-auto680):00054         * all files containing the complete source.
                      (fig-forth-auto680):00055         * 
                      (fig-forth-auto680):00056         * This is the MIT model license, as published by the Open Source Consortium,
                      (fig-forth-auto680):00057         * with associated documentation defined.
                      (fig-forth-auto680):00058         * It was chosen to reflect the spirit of the original 
                      (fig-forth-auto680):00059         * terms of use, which used archaic legal terminology.
                      (fig-forth-auto680):00060         *
                      (fig-forth-auto680):00061         
                      (fig-forth-auto680):00062         * Authors of the 6800 model:
                      (fig-forth-auto680):00063         * === Primary: Dave Lion,
                      (fig-forth-auto680):00064         * ===  with help from
                      (fig-forth-auto680):00065         * === Bob Smith,
                      (fig-forth-auto680):00066         * === LaFarr Stuart,
                      (fig-forth-auto680):00067         * === The Forth Interest Group
                      (fig-forth-auto680):00068         * === PO Box 1105
                      (fig-forth-auto680):00069         * === San Carlos, CA 94070
                      (fig-forth-auto680):00070         * ===  and
                      (fig-forth-auto680):00071         * === Unbounded Computing
                      (fig-forth-auto680):00072         * === 1134-K Aster Ave.
                      (fig-forth-auto680):00073         * === Sunnyvale, CA 94086
                      (fig-forth-auto680):00074         *
     0002             (fig-forth-auto680):00075         NATWID  EQU     2       ; bytes per natural integer/pointer
                      (fig-forth-auto680):00076         *  The original version was developed on an AMI EVK 300 PROTO
                      (fig-forth-auto680):00077         *  system using an ACIA for the I/O.
                      (fig-forth-auto680):00078         *  This version is developed targeting the Tandy Color Computer.
                      (fig-forth-auto680):00079         
                      (fig-forth-auto680):00080         *  All terminal 1/0
                      (fig-forth-auto680):00081         *  is done in three subroutines:
                      (fig-forth-auto680):00082         *   PEMIT  ( word # 182 )
                      (fig-forth-auto680):00083         *   PKEY   (        183 )
                      (fig-forth-auto680):00084         *   PQTERM (        184 )
                      (fig-forth-auto680):00085         *
                      (fig-forth-auto680):00086         *  The FORTH words for disc related I/O follow the model
                      (fig-forth-auto680):00087         *  of the FORTH Interest Group, but have not yet been
                      (fig-forth-auto680):00088         *  tested using a real disc.
                      (fig-forth-auto680):00089         *
                      (fig-forth-auto680):00090         *  Addresses in the 6800 implementation reflect the fact that,
                      (fig-forth-auto680):00091         *  on the development system, it was convenient to
                      (fig-forth-auto680):00092         *  write-protect memory at hex 1000, and leave the first
                      (fig-forth-auto680):00093         *  4K bytes write-enabled. As a consequence, code from
                      (fig-forth-auto680):00094         *  location $1000 to lable ZZZZ could be put in ROM.
                      (fig-forth-auto680):00095         *  Minor deviations from the model were made in the
                      (fig-forth-auto680):00096         *  initialization and words ?STACK and FORGET
                      (fig-forth-auto680):00097         *  in order to do this.
                      (fig-forth-auto680):00098         *  Those deviations will be altered in this 
                      (fig-forth-auto680):00099         *  implementation for the 6809 -- Color Computer.
                      (fig-forth-auto680):00100         *  
                      (fig-forth-auto680):00101         
                      (fig-forth-auto680):00102         *
     7FFF             (fig-forth-auto680):00103         MEMT32  EQU     $7FFF   absolute end of all ram
     3FFF             (fig-forth-auto680):00104         MEMT16  EQU     $3FFF
     7FFF             (fig-forth-auto680):00105         MEMTOP  EQU     MEMT32  ; tentative guess
     FBCE             (fig-forth-auto680):00106         ACIAC   EQU     $FBCE   the ACIA control address and
     FBCF             (fig-forth-auto680):00107         ACIAD   EQU     ACIAC+1 data address for PROTO
                      (fig-forth-auto680):00108                 PAGE
                      (fig-forth-auto680):00109         *  MEMORY MAP for this 16K|32K system:
                      (fig-forth-auto680):00110         *  ( delineated so that systems with 4k byte write-
                      (fig-forth-auto680):00111         *   protected segments can write protect FORTH )
                      (fig-forth-auto680):00112         *
                      (fig-forth-auto680):00113         * addr.         contents                pointer init by
                      (fig-forth-auto680):00114         * ****  ******************************* ******* ******
                      (fig-forth-auto680):00115         *       2nd through 4th per-user tables
                      (fig-forth-auto680):00116         * 4000|7D00
     0100             (fig-forth-auto680):00117         USERSZ  EQU     256     ; (Addressable by DP)
     0001             (fig-forth-auto680):00118         USER16  EQU     1       ; We can change these for ROMPACK or 64K.
     0004             (fig-forth-auto680):00119         USER32  EQU     4
     0004             (fig-forth-auto680):00120         USERCT  EQU     USER32
     3F00             (fig-forth-auto680):00121         IUP16   EQU     MEMT16+1-USER16*USERSZ
     7C00             (fig-forth-auto680):00122         IUP32   EQU     MEMT32+1-USER32*USERSZ
     7C00             (fig-forth-auto680):00123         IUP     EQU     IUP32
     007C             (fig-forth-auto680):00124         IUPDP   EQU     IUP/256
                      (fig-forth-auto680):00125         *       user tables of variables
                      (fig-forth-auto680):00126         *       registers & pointers for the virtual machine
                      (fig-forth-auto680):00127         *       scratch area used by various words
                      (fig-forth-auto680):00128         * 3F00|7C00                             <== UP (DICTPT)
                      (fig-forth-auto680):00129         * 3EFF|7BFF                                     HI
                      (fig-forth-auto680):00130         *       substitute for disc mass memory
     0003             (fig-forth-auto680):00131         RAMSCR  EQU     3
     0400             (fig-forth-auto680):00132         SCRSZ   EQU     1024
                      (fig-forth-auto680):00133         * 3300|7000                                     LO,MEMEND
     3300             (fig-forth-auto680):00134         RAMD16  EQU     IUP16-RAMSCR*SCRSZ
     7000             (fig-forth-auto680):00135         RAMD32  EQU     IUP32-RAMSCR*SCRSZ
     7000             (fig-forth-auto680):00136         RAMDSK  EQU     RAMD32
     3300             (fig-forth-auto680):00137         MEME16  EQU     RAMD16
     7000             (fig-forth-auto680):00138         MEME32  EQU     RAMD32
     7000             (fig-forth-auto680):00139         MEMEND  EQU     MEME32
                      (fig-forth-auto680):00140         * 32FF|6FFF
                      (fig-forth-auto680):00141         *       4 buffer sectors of VIRTUAL MEMORY
     0004             (fig-forth-auto680):00142         NBLK    EQU     4 ; # of disc buffer blocks for virtual memory
                      (fig-forth-auto680):00143         * Should NBLK be SCRSZ/SECTSZ?
                      (fig-forth-auto680):00144         *  each block is SECTSZ+SECTRL bytes in size,
                      (fig-forth-auto680):00145         *  holding SECTSZ characters
     0100             (fig-forth-auto680):00146         SECTSZ  EQU     256
     0008             (fig-forth-auto680):00147         SECTRL  EQU     8
     0420             (fig-forth-auto680):00148         BUFSZ   EQU     (SECTSZ+SECTRL)*NBLK
                      (fig-forth-auto680):00149         * 2EE0|6BE0                                     FIRST
     2EE0             (fig-forth-auto680):00150         BUFB16  EQU     MEME16-BUFSZ
     6BE0             (fig-forth-auto680):00151         BUFB32  EQU     MEME32-BUFSZ
     6BE0             (fig-forth-auto680):00152         BUFBAS  EQU     BUFB32
                      (fig-forth-auto680):00153         * "end" of "usable ram" -- in 16K
                      (fig-forth-auto680):00154         * 2EE0|6BE0                             <== RP  RINIT
     2EE0             (fig-forth-auto680):00155         IRP16   EQU     BUFB16
     6BE0             (fig-forth-auto680):00156         IRP32   EQU     BUFB32
     6BE0             (fig-forth-auto680):00157         IRP     EQU     IRP32
                      (fig-forth-auto680):00158         *       RETURN STACK
                      (fig-forth-auto680):00159         *       (64|112 levels nesting)
     0080             (fig-forth-auto680):00160         RSTK16  EQU     128
     00E0             (fig-forth-auto680):00161         RSTK32  EQU     224
                      (fig-forth-auto680):00162         * (2E60|6B00)
     2E60             (fig-forth-auto680):00163         SFTB16  EQU     IRP16-RSTK16
     6B00             (fig-forth-auto680):00164         SFTB32  EQU     IRP32-RSTK32
     6B00             (fig-forth-auto680):00165         SFTBND  EQU     SFTB32
                      (fig-forth-auto680):00166         *       INPUT LINE BUFFER
                      (fig-forth-auto680):00167         *       holds up to 256 characters
                      (fig-forth-auto680):00168         *       and is scanned upward by IN
                      (fig-forth-auto680):00169         *       starting at TIB
     0100             (fig-forth-auto680):00170         TIBSZ   EQU     256
                      (fig-forth-auto680):00171         * 2D60|6A00
     2D60             (fig-forth-auto680):00172         ITIB16  EQU     SFTB16-TIBSZ
     6A00             (fig-forth-auto680):00173         ITIB32  EQU     SFTB32-TIBSZ
     6A00             (fig-forth-auto680):00174         ITIB    EQU     ITIB32
                      (fig-forth-auto680):00175         * 2D60|6A00                             <== IN  TIB
     2D60             (fig-forth-auto680):00176         ISP16   EQU     ITIB16
     6A00             (fig-forth-auto680):00177         ISP32   EQU     ITIB32
     6A00             (fig-forth-auto680):00178         ISP     EQU     ISP32
                      (fig-forth-auto680):00179         * 2D60|6A00                             <== SP  SP0,SINIT
                      (fig-forth-auto680):00180         *       DATA STACK
                      (fig-forth-auto680):00181         *    |  grows downward from 2A60|6A00
                      (fig-forth-auto680):00182         *    v
                      (fig-forth-auto680):00183         *  - -
                      (fig-forth-auto680):00184         *    |
                      (fig-forth-auto680):00185         *    I  DICTIONARY grows upward
                      (fig-forth-auto680):00186         * 
                      (fig-forth-auto680):00187         * ????  end of ram-dictionary.          <== DICTPT      DPINIT
                      (fig-forth-auto680):00188         *       "TASK"
                      (fig-forth-auto680):00189         *
                      (fig-forth-auto680):00190         * ????  "FORTH" ( a word )              <=, <== CONTEXT
                      (fig-forth-auto680):00191         *                                       `==== CURRENT
                      (fig-forth-auto680):00192         *       start of ram-dictionary.
                      (fig-forth-auto680):00193         *
                      (fig-forth-auto680):00194         * >>>>>> memory from here up must be in RAM area <<<<<<
                      (fig-forth-auto680):00195         *
                      (fig-forth-auto680):00196         * ????
                      (fig-forth-auto680):00197         *       6k of romable "FORTH"           <== IP  ABORT
                      (fig-forth-auto680):00198         *                                       <== W
                      (fig-forth-auto680):00199         *       the VIRTUAL FORTH MACHINE
                      (fig-forth-auto680):00200         *
                      (fig-forth-auto680):00201         * 1208  initialization tables
                      (fig-forth-auto680):00202         * 1204 <<< WARM START ENTRY >>>
                      (fig-forth-auto680):00203         * 1200 <<< COLD START ENTRY >>>
                      (fig-forth-auto680):00204         * 1200  lowest address used by FORTH
                      (fig-forth-auto680):00205         *
     1200             (fig-forth-auto680):00206         CODEBG  EQU $1200
                      (fig-forth-auto680):00207         * CODEBG        EQU $3000
                      (fig-forth-auto680):00208         *
                      (fig-forth-auto680):00209         * >>>>>> memory from here down left alone <<<<<<
                      (fig-forth-auto680):00210         * >>>>>> so we can safely call ROM routines <<<<<<
                      (fig-forth-auto680):00211         *
                      (fig-forth-auto680):00212         * 0000
                      (fig-forth-auto680):00213                 PAGE
                      (fig-forth-auto680):00214         ***
                      (fig-forth-auto680):00215         *
                      (fig-forth-auto680):00216         * CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
                      (fig-forth-auto680):00217         *
                      (fig-forth-auto680):00218         * IP (hardware Y) points to the current instruction ( pre-increment mode )
                      (fig-forth-auto680):00219         * RP (hardware S) points to last return address pushedin return stack
                      (fig-forth-auto680):00220         * SP (hardware U) points to last byte pushed in data stack
                      (fig-forth-auto680):00221         *
                      (fig-forth-auto680):00222         * Y must be IP when NEXT is entered (if using the inner loop).
                      (fig-forth-auto680):00223         *
                      (fig-forth-auto680):00224         *       When A and B hold one 16 bit FORTH data word,
                      (fig-forth-auto680):00225         *       A contains the high byte, B, the low byte.
                      (fig-forth-auto680):00226         *
                      (fig-forth-auto680):00227         * UP (hardware DP) is the base of per-task ("user") variables.
                      (fig-forth-auto680):00228         * (Be careful of the stray semantics of "user".)
                      (fig-forth-auto680):00229         *
                      (fig-forth-auto680):00230         * W (hardware X) is the pointer to the "code field" address of native CPU 
                      (fig-forth-auto680):00231         * machine code to be executed for the definition of the dictionary word 
                      (fig-forth-auto680):00232         * to be executed/currently executing.
                      (fig-forth-auto680):00233         * The following natural integer (word) begins any "parameter section" 
                      (fig-forth-auto680):00234         * (body) -- similar to a "this" pointer, but not the same.
                      (fig-forth-auto680):00235         * It may be native CPU machine code, or it may be a global variable, 
                      (fig-forth-auto680):00236         * or it may be a list of Forth definition words (addresses).
                      (fig-forth-auto680):00237         *
                      (fig-forth-auto680):00238         * ======
                      (fig-forth-auto680):00239         * This implementation uses the native subroutine architecture 
                      (fig-forth-auto680):00240         * rather than a postponed-push call that the 6800 model VM uses
                      (fig-forth-auto680):00241         * to save code and time in leaf routines. 
                      (fig-forth-auto680):00242         *
                      (fig-forth-auto680):00243         * This should allow directly calling many of the Forth words 
                      (fig-forth-auto680):00244         * from assembly language code. 
                      (fig-forth-auto680):00245         * (Be aware of the need for a valid W in some cases.)
                      (fig-forth-auto680):00246         * It won't allow mixing assembly language directly into Forth word lists.
                      (fig-forth-auto680):00247         * ======
                      (fig-forth-auto680):00248         *
                      (fig-forth-auto680):00249         * boolean flags:
                      (fig-forth-auto680):00250         * 0 is false, anything else is true.
                      (fig-forth-auto680):00251         * Most places in this model that set a boolean flag set true as 1.
                      (fig-forth-auto680):00252         * This is in contrast to many models that set a boolean flag as -1.
                      (fig-forth-auto680):00253         *
                      (fig-forth-auto680):00254         ***
                      (fig-forth-auto680):00255         
                      (fig-forth-auto680):00256                 PAGE
                      (fig-forth-auto680):00257         *       This system is shown with one user (task), 
                      (fig-forth-auto680):00258         *       but additional users (tasks) may be added
                      (fig-forth-auto680):00259         *       by allocating additional user tables:
                      (fig-forth-auto680):00260         *
                      (fig-forth-auto680):00261                 ORG     IUP
7C00                  (fig-forth-auto680):00262         UBASE   RMB     USERSZ
7D00                  (fig-forth-auto680):00263         UBASEX  RMB     USERSZ data table for extra users
                      (fig-forth-auto680):00264         *
                      (fig-forth-auto680):00265         *       Some of this stuff gets initialized during
                      (fig-forth-auto680):00266         *       COLD start and WARM start:
                      (fig-forth-auto680):00267         *       [ names correspond to FORTH words of similar (no X) name ]
                      (fig-forth-auto680):00268         *
                      (fig-forth-auto680):00269                 ORG     IUP
     7C00             (fig-forth-auto680):00270         UORIG   EQU     *
                      (fig-forth-auto680):00271         *               A few useful VM variables
                      (fig-forth-auto680):00272         * Will be removed when they are no longer needed.
                      (fig-forth-auto680):00273         * All are replaced by 6809 registers.
                      (fig-forth-auto680):00274         
7C00                  (fig-forth-auto680):00275         N       RMB     10      used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
                      (fig-forth-auto680):00276         *                               SP@,SWAP,DOES>,COLD
                      (fig-forth-auto680):00277         
                      (fig-forth-auto680):00278         
                      (fig-forth-auto680):00279         *       These locations are used by the TRACE routine :
                      (fig-forth-auto680):00280         
7C0A                  (fig-forth-auto680):00281         TRLIM   RMB     1       the count for tracing without user intervention
7C0B                  (fig-forth-auto680):00282         TRACEM  RMB     1       non-zero = trace mode
7C0C                  (fig-forth-auto680):00283         BRKPT   RMB     2       the breakpoint address at which
                      (fig-forth-auto680):00284         *                       the program will go into trace mode
7C0E                  (fig-forth-auto680):00285         VECT    RMB     2       vector to machine code
                      (fig-forth-auto680):00286         *       (only needed if the TRACE routine is resident)
                      (fig-forth-auto680):00287         
                      (fig-forth-auto680):00288         
                      (fig-forth-auto680):00289         *       Registers used by the FORTH virtual machine:
                      (fig-forth-auto680):00290         *       Starting at $OOFO:
                      (fig-forth-auto680):00291         
                      (fig-forth-auto680):00292         
7C10                  (fig-forth-auto680):00293         W       RMB     2       the instruction register points to 6800 code
                      (fig-forth-auto680):00294         * This is not exactly accurate. Points to the definiton body,
                      (fig-forth-auto680):00295         * which is native CPU machine code when it is native CPU machine code.
7C12                  (fig-forth-auto680):00296         IP      RMB     2       the instruction pointer points to pointer to 6800 code
7C14                  (fig-forth-auto680):00297         RP      RMB     2       the return stack pointer
7C16                  (fig-forth-auto680):00298         UP      RMB     2       the pointer to base of current user's 'USER' table
                      (fig-forth-auto680):00299         *               ( altered during multi-tasking )
                      (fig-forth-auto680):00300         *
                      (fig-forth-auto680):00301         *UORIG  RMB     6       3 reserved variables
7C18                  (fig-forth-auto680):00302                 RMB     6       3 reserved variables
7C1E                  (fig-forth-auto680):00303         XSPZER  RMB     2       initial top of data stack for this user
7C20                  (fig-forth-auto680):00304         XRZERO  RMB     2       initial top of return stack
7C22                  (fig-forth-auto680):00305         XTIB    RMB     2       start of terminal input buffer
7C24                  (fig-forth-auto680):00306         XWIDTH  RMB     2       name field width
7C26                  (fig-forth-auto680):00307         XWARN   RMB     2       warning message mode (0 = no disc)
7C28                  (fig-forth-auto680):00308         XFENCE  RMB     2       fence for FORGET
7C2A                  (fig-forth-auto680):00309         XDICTP  RMB     2       dictionary pointer
7C2C                  (fig-forth-auto680):00310         XVOCL   RMB     2       vocabulary linking
7C2E                  (fig-forth-auto680):00311         XBLK    RMB     2       disc block being accessed
7C30                  (fig-forth-auto680):00312         XIN     RMB     2       scan pointer into the block
7C32                  (fig-forth-auto680):00313         XOUT    RMB     2       cursor position
7C34                  (fig-forth-auto680):00314         XSCR    RMB     2       disc screen being accessed ( O=terminal )
7C36                  (fig-forth-auto680):00315         XOFSET  RMB     2       disc sector offset for multi-disc
7C38                  (fig-forth-auto680):00316         XCONT   RMB     2       last word in primary search vocabulary
7C3A                  (fig-forth-auto680):00317         XCURR   RMB     2       last word in extensible vocabulary
7C3C                  (fig-forth-auto680):00318         XSTATE  RMB     2       flag for 'interpret' or 'compile' modes
7C3E                  (fig-forth-auto680):00319         XBASE   RMB     2       number base for I/O numeric conversion
7C40                  (fig-forth-auto680):00320         XDPL    RMB     2       decimal point place
7C42                  (fig-forth-auto680):00321         XFLD    RMB     2       
7C44                  (fig-forth-auto680):00322         XCSP    RMB     2       current stack position, for compile checks
7C46                  (fig-forth-auto680):00323         XRNUM   RMB     2       
7C48                  (fig-forth-auto680):00324         XHLD    RMB     2       
7C4A                  (fig-forth-auto680):00325         XDELAY  RMB     2       carriage return delay count
7C4C                  (fig-forth-auto680):00326         XCOLUM  RMB     2       carriage width
7C4E                  (fig-forth-auto680):00327         IOSTAT  RMB     2       last acia status from write/read
7C50                  (fig-forth-auto680):00328                 RMB     2       ( 4 spares! )
7C52                  (fig-forth-auto680):00329                 RMB     2       
7C54                  (fig-forth-auto680):00330                 RMB     2       
7C56                  (fig-forth-auto680):00331                 RMB     2       
                      (fig-forth-auto680):00332         
                      (fig-forth-auto680):00333         
                      (fig-forth-auto680):00334         
                      (fig-forth-auto680):00335         
                      (fig-forth-auto680):00336         *
                      (fig-forth-auto680):00337         *
                      (fig-forth-auto680):00338         *   end of user table, start of common system variables
                      (fig-forth-auto680):00339         *
                      (fig-forth-auto680):00340         *
                      (fig-forth-auto680):00341         *
7C58                  (fig-forth-auto680):00342         XUSE    RMB     2
7C5A                  (fig-forth-auto680):00343         XPREV   RMB     2
7C5C                  (fig-forth-auto680):00344                 RMB     4       ( spares )
                      (fig-forth-auto680):00345         
                      (fig-forth-auto680):00346                 PAGE
                      (fig-forth-auto680):00347         *    The FORTH program ( address $1200 to about $27FF ) will be written
                      (fig-forth-auto680):00348         *    so that it can be in a ROM, or write-protected if desired,
                      (fig-forth-auto680):00349         * but right now we're just getting it running.
                      (fig-forth-auto680):00350                 ORG     CODEBG
                      (fig-forth-auto680):00351         
                      (fig-forth-auto680):00352         * ######>> screen 3 <<
                      (fig-forth-auto680):00353         *
                      (fig-forth-auto680):00354         ***************************
                      (fig-forth-auto680):00355         **  C O L D   E N T R Y  **
                      (fig-forth-auto680):00356         ***************************
1200 12               (fig-forth-auto680):00357         ORIG    NOP
                      (fig-forth-auto680):00358         *       JMP     CENT
1201 171029           (fig-forth-auto680):00359                 LBSR    CENT
                      (fig-forth-auto680):00360         ***************************
                      (fig-forth-auto680):00361         **  W A R M   E N T R Y  **
                      (fig-forth-auto680):00362         ***************************
1204 12               (fig-forth-auto680):00363                 NOP
                      (fig-forth-auto680):00364         *       JMP     WENT    warm-start code, keeps current dictionary intact
1205 171062           (fig-forth-auto680):00365                 LBSR    WENT    warm-start code, keeps current dictionary intact
     7C               (fig-forth-auto680):00366                 SETDP   IUPDP
                      (fig-forth-auto680):00367         
                      (fig-forth-auto680):00368         *
                      (fig-forth-auto680):00369         ******* startup parmeters **************************
                      (fig-forth-auto680):00370         *
1208 68090000         (fig-forth-auto680):00371                 FDB     $6809,0000      cpu & revision
120C 0000             (fig-forth-auto680):00372                 FDB     0       topmost word in FORTH vocabulary
                      (fig-forth-auto680):00373         * BACKSP        FDB     $7F     backspace character for editing 
120E 0008             (fig-forth-auto680):00374         BACKSP  FDB     $08     backspace character for editing 
1210 7C00             (fig-forth-auto680):00375         UPINIT  FDB     UORIG   initial user area
                      (fig-forth-auto680):00376         * UPINIT        FDB     UORIG   initial user area
1212 6A00             (fig-forth-auto680):00377         SINIT   FDB     ISP     ; initial top of data stack
                      (fig-forth-auto680):00378         * SINIT FDB     ORIG-$D0        initial top of data stack
1214 6BE0             (fig-forth-auto680):00379         RINIT   FDB     IRP     ; initial top of return stack
                      (fig-forth-auto680):00380         * RINIT FDB     ORIG-2  initial top of return stack
1216 6A00             (fig-forth-auto680):00381                 FDB     ITIB    ; terminal input buffer
                      (fig-forth-auto680):00382         *       FDB     ORIG-$D0        terminal input buffer
1218 001F             (fig-forth-auto680):00383                 FDB     31      initial name field width
121A 0000             (fig-forth-auto680):00384                 FDB     0       initial warning mode (0 = no disc)
121C 2AD0             (fig-forth-auto680):00385         FENCIN  FDB     REND    initial fence
121E 2AD0             (fig-forth-auto680):00386         DPINIT  FDB     REND    cold start value for DICTPT
1220 2AA5             (fig-forth-auto680):00387         VOCINT  FDB     FORTH+4*NATWID  
1222 0084             (fig-forth-auto680):00388         COLINT  FDB     132     initial terminal carriage width
1224 0004             (fig-forth-auto680):00389         DELINT  FDB     4       initial carriage return delay
                      (fig-forth-auto680):00390         ****************************************************
                      (fig-forth-auto680):00391         *
                      (fig-forth-auto680):00392                 PAGE
                      (fig-forth-auto680):00393         *
                      (fig-forth-auto680):00394         * ######>> screen 13 <<
                      (fig-forth-auto680):00395         * These were of questionable use anyway, 
                      (fig-forth-auto680):00396         * kept here now to satisfy the assembler and show hints.
                      (fig-forth-auto680):00397         * They're too much trouble to use with native subroutine call anyway.
                      (fig-forth-auto680):00398         * PULABX        PULS A  ; 24 cycles until 'NEXT'
                      (fig-forth-auto680):00399         *       PULS B  ; 
                      (fig-forth-auto680):00400         * PULABX        PULU A,B        ; ?? cycles until 'NEXT'
                      (fig-forth-auto680):00401         * STABX STA 0,X 16 cycles until 'NEXT'
                      (fig-forth-auto680):00402         *       STB 1,X
                      (fig-forth-auto680):00403         * STABX STD 0,X ; ?? cycles until 'NEXT'
1226 2000             (fig-forth-auto680):00404                 BRA     NEXT
                      (fig-forth-auto680):00405         * GETX  LDA 0,X 18 cycles until 'NEXT'
                      (fig-forth-auto680):00406         *       LDB 1,X
                      (fig-forth-auto680):00407         * GETX  LDD 0,X ?? cycles until 'NEXT'
                      (fig-forth-auto680):00408         * PUSHBA        PSHS B  ; 8 cycles until 'NEXT'
                      (fig-forth-auto680):00409         *       PSHS A  ; 
                      (fig-forth-auto680):00410         * PUSHBA        PSHU A,B        ; ?? cycles until 'NEXT'
                      (fig-forth-auto680):00411         
                      (fig-forth-auto680):00412         
                      (fig-forth-auto680):00413         *
                      (fig-forth-auto680):00414         * "NEXT" takes ?? cycles if TRACE is removed,
                      (fig-forth-auto680):00415         *
                      (fig-forth-auto680):00416         * and ?? cycles if trace is present and NOT tracing.
                      (fig-forth-auto680):00417         *
                      (fig-forth-auto680):00418         * = = = = = = =   t h e   v i r t u a l   m a c h i n e   = = = = =
                      (fig-forth-auto680):00419         *                                                                 =
                      (fig-forth-auto680):00420         * NEXT itself might just completely go away.
                      (fig-forth-auto680):00421         * About the only reason to keep it is to allowing executing a list
                      (fig-forth-auto680):00422         * which allows a cheap TRACE routine.
                      (fig-forth-auto680):00423         *
                      (fig-forth-auto680):00424         * NEXT is a loop which implements the Forth VM.
                      (fig-forth-auto680):00425         * It basically cycles through calling the code out of code lists,
                      (fig-forth-auto680):00426         * one at a time.
                      (fig-forth-auto680):00427         * Using a native CPU return for this uses a few extra cycles per call,
                      (fig-forth-auto680):00428         * compared to simply jumping to each definition and jumping back 
                      (fig-forth-auto680):00429         * to the known beginning of the loop,
                      (fig-forth-auto680):00430         * but the loop itself is really only there for convenience.
                      (fig-forth-auto680):00431         * 
                      (fig-forth-auto680):00432         * This implementation uses the native subroutine call,
                      (fig-forth-auto680):00433         * to break the wall between Forth code and non-Forth code.
                      (fig-forth-auto680):00434         *
                      (fig-forth-auto680):00435         * NEXT  LDX     IP
                      (fig-forth-auto680):00436         *       LEAX 1,X        ;               pre-increment mode
                      (fig-forth-auto680):00437         *       LEAX 1,X        ; 
                      (fig-forth-auto680):00438         *       STX     IP
1228                  (fig-forth-auto680):00439         NEXT    ; IP is Y, push before using, pull before you come back here.
                      (fig-forth-auto680):00440         * 
                      (fig-forth-auto680):00441         * NEXT2 LDX     0,X     get W which points to CFA of word to be done
1228 AEA1             (fig-forth-auto680):00442         NEXT2   LDX     ,Y++    get W which points to CFA of word to be done
122A 8D08             (fig-forth-auto680):00443                 BSR     DBGNAM
122C 8D58             (fig-forth-auto680):00444                 BSR     DBGREG
                      (fig-forth-auto680):00445         * But NEXT2 is too much trouble to use with subroutine threading anyway.
                      (fig-forth-auto680):00446         * NEXT3 STX     W
122E                  (fig-forth-auto680):00447         NEXT3   ; W is X until you use X for something else. (TOS points back here.)
                      (fig-forth-auto680):00448         * But NEXT3 is too much trouble to use with subroutine threading anyway.
                      (fig-forth-auto680):00449         *       LDX     0,X     get VECT which points to executable code
                      (fig-forth-auto680):00450         *                                                                 =
                      (fig-forth-auto680):00451         * The next instruction could be patched to JMP TRACE              =
                      (fig-forth-auto680):00452         * if a TRACE routine is available:                                =
                      (fig-forth-auto680):00453         *                                                                 =
                      (fig-forth-auto680):00454         *       JMP     0,X
                      (fig-forth-auto680):00455         
122E AD94             (fig-forth-auto680):00456                 JSR     [,X]    ; Saving the postinc cycles,
                      (fig-forth-auto680):00457         *                       ; but X must be bumped NATWID to the parameters.
                      (fig-forth-auto680):00458         *       NOP
                      (fig-forth-auto680):00459         *       JMP     TRACE   ( an alternate for the above )
1230 8D54             (fig-forth-auto680):00460                 BSR     DBGREG  ( an alternate for the above )
                      (fig-forth-auto680):00461         * In other words, with the call and the NOP,
                      (fig-forth-auto680):00462         * there is room to patch the call with a JMP to your TRACE 
                      (fig-forth-auto680):00463         * routine, which you have to provide.
1232 20F4             (fig-forth-auto680):00464                 BRA     NEXT
                      (fig-forth-auto680):00465         *
1234 3437             (fig-forth-auto680):00466         DBGNAM  PSHS    CC,D,X,Y
1236 0D0B             (fig-forth-auto680):00467                 TST     <TRACEM
1238 2724             (fig-forth-auto680):00468                 BEQ     DBGNrt
123A 301D             (fig-forth-auto680):00469                 LEAX    -3,X
123C E682             (fig-forth-auto680):00470         DBGNlf  LDB     ,-X
123E 2AFC             (fig-forth-auto680):00471                 BPL     DBGNlf
1240 108E04C0         (fig-forth-auto680):00472                 LDY     #$4C0
1244 E680             (fig-forth-auto680):00473                 LDB     ,X+
1246 E680             (fig-forth-auto680):00474         DBGNlp  LDB     ,X+
1248 2B04             (fig-forth-auto680):00475                 BMI     DBGNll
124A E7A0             (fig-forth-auto680):00476                 STB     ,Y+
124C 20F8             (fig-forth-auto680):00477                 BRA     DBGNlp
124E C47F             (fig-forth-auto680):00478         DBGNll  ANDB    #$7F
1250 E7A0             (fig-forth-auto680):00479                 STB     ,Y+
1252 C660             (fig-forth-auto680):00480                 LDB     #$60
1254 2002             (fig-forth-auto680):00481                 BRA     DBGNlt
1256 E7A0             (fig-forth-auto680):00482         DBGNlc  STB     ,Y+     
1258 108C04E0         (fig-forth-auto680):00483         DBGNlt  CMPY    #$4E0
125C 25F8             (fig-forth-auto680):00484                 BLO     DBGNlc
125E 35B7             (fig-forth-auto680):00485         DBGNrt  PULS    CC,D,X,Y,PC
                      (fig-forth-auto680):00486         *
                      (fig-forth-auto680):00487         *
1260 54               (fig-forth-auto680):00488         MKhxBh  LSRB
1261 54               (fig-forth-auto680):00489                 LSRB
1262 54               (fig-forth-auto680):00490                 LSRB
1263 54               (fig-forth-auto680):00491                 LSRB
1264 C40F             (fig-forth-auto680):00492         MKhxBl  ANDB    #$0F
1266 CB30             (fig-forth-auto680):00493                 ADDB    #$30
1268 C139             (fig-forth-auto680):00494                 CMPB    #$39
126A 2302             (fig-forth-auto680):00495                 BLS     MKhxBx
126C CBC7             (fig-forth-auto680):00496                 ADDB    #$C7    ; ($40-$39)-$40
126E 39               (fig-forth-auto680):00497         MKhxBx  RTS
                      (fig-forth-auto680):00498         *
126F 1E89             (fig-forth-auto680):00499         OUThxA  EXG     A,B
1271 8D05             (fig-forth-auto680):00500                 BSR     OUThxB
1273 1E89             (fig-forth-auto680):00501                 EXG     A,B
1275 39               (fig-forth-auto680):00502                 RTS
                      (fig-forth-auto680):00503         *
1276 8DF7             (fig-forth-auto680):00504         OUThxD  BSR     OUThxA
1278 3404             (fig-forth-auto680):00505         OUThxB  PSHS    B
127A 8DE4             (fig-forth-auto680):00506                 BSR     MKhxBh
127C E780             (fig-forth-auto680):00507                 STB     ,X+
127E E6E4             (fig-forth-auto680):00508                 LDB     ,S
1280 8DE2             (fig-forth-auto680):00509                 BSR     MKhxBl
1282 E780             (fig-forth-auto680):00510                 STB     ,X+
1284 3584             (fig-forth-auto680):00511                 PULS    B,PC
                      (fig-forth-auto680):00512         *
1286 347F             (fig-forth-auto680):00513         DBGREG  PSHS    U,Y,X,DP,B,A,CC
1288 0D0B             (fig-forth-auto680):00514                 TST     <TRACEM
128A 102700DF         (fig-forth-auto680):00515                 LBEQ    DBGRrt
128E 318D00DD         (fig-forth-auto680):00516                 LEAY    DBGRLB,PCR
1292 8E04E0           (fig-forth-auto680):00517                 LDX     #$4E0
1295 ECA1             (fig-forth-auto680):00518         DBGRlp  LDD     ,Y++
1297 2704             (fig-forth-auto680):00519                 BEQ     DBGRdn
1299 ED81             (fig-forth-auto680):00520                 STD     ,X++
129B 20F8             (fig-forth-auto680):00521                 BRA     DBGRlp
129D 8E0500           (fig-forth-auto680):00522         DBGRdn  LDX     #$500
12A0 A663             (fig-forth-auto680):00523                 LDA     3,S     ; DP
12A2 E6E4             (fig-forth-auto680):00524                 LDB     ,S      ; CC
12A4 8DD0             (fig-forth-auto680):00525                 BSR     OUThxD
12A6 C660             (fig-forth-auto680):00526                 LDB     #$60
12A8 E780             (fig-forth-auto680):00527                 STB     ,X+
12AA EC6A             (fig-forth-auto680):00528                 LDD     3*NATWID+4,S    ; PC:505
12AC 8DC8             (fig-forth-auto680):00529                 BSR     OUThxD
12AE C660             (fig-forth-auto680):00530                 LDB     #$60
12B0 E780             (fig-forth-auto680):00531                 STB     ,X+
12B2 1F40             (fig-forth-auto680):00532                 TFR     S,D     ; 509
12B4 C3000C           (fig-forth-auto680):00533                 ADDD    #4*NATWID+4
12B7 8DBD             (fig-forth-auto680):00534                 BSR     OUThxD
12B9 EC68             (fig-forth-auto680):00535                 LDD     2*NATWID+4,S    ; U:50E
12BB 8DB9             (fig-forth-auto680):00536                 BSR     OUThxD
12BD C660             (fig-forth-auto680):00537                 LDB     #$60
12BF E780             (fig-forth-auto680):00538                 STB     ,X+
12C1 EC66             (fig-forth-auto680):00539                 LDD     1*NATWID+4,S    ; Y:513
12C3 8DB1             (fig-forth-auto680):00540                 BSR     OUThxD
12C5 EC64             (fig-forth-auto680):00541                 LDD     0*NATWID+4,S    ; X at 517
12C7 8DAD             (fig-forth-auto680):00542                 BSR     OUThxD
12C9 C660             (fig-forth-auto680):00543                 LDB     #$60
12CB E780             (fig-forth-auto680):00544                 STB     ,X+
12CD EC61             (fig-forth-auto680):00545                 LDD     1,S     ; D at 51C
12CF 8DA5             (fig-forth-auto680):00546                 BSR     OUThxD
12D1 C660             (fig-forth-auto680):00547                 LDB     #$60
12D3 E780             (fig-forth-auto680):00548                 STB     ,X+
12D5 E780             (fig-forth-auto680):00549                 STB     ,X+
12D7 E780             (fig-forth-auto680):00550                 STB     ,X+
12D9 E780             (fig-forth-auto680):00551                 STB     ,X+
12DB E780             (fig-forth-auto680):00552                 STB     ,X+
12DD ECF80A           (fig-forth-auto680):00553                 LDD     [3*NATWID+4,S]  ; PC
12E0 8D94             (fig-forth-auto680):00554                 BSR     OUThxD
12E2 C660             (fig-forth-auto680):00555                 LDB     #$60
12E4 E780             (fig-forth-auto680):00556                 STB     ,X+
12E6 EC6C             (fig-forth-auto680):00557                 LDD     4*NATWID+4,S    ; S
12E8 8D8C             (fig-forth-auto680):00558                 BSR     OUThxD
12EA ECF808           (fig-forth-auto680):00559                 LDD     [2*NATWID+4,S]  ; U
12ED 8D87             (fig-forth-auto680):00560                 BSR     OUThxD
12EF C660             (fig-forth-auto680):00561                 LDB     #$60
12F1 E780             (fig-forth-auto680):00562                 STB     ,X+
12F3 ECF806           (fig-forth-auto680):00563                 LDD     [1*NATWID+4,S]  ; Y
12F6 17FF7D           (fig-forth-auto680):00564                 LBSR    OUThxD
12F9 ECF804           (fig-forth-auto680):00565                 LDD     [0*NATWID+4,S]  ; X
12FC 17FF77           (fig-forth-auto680):00566                 LBSR    OUThxD
12FF C660             (fig-forth-auto680):00567                 LDB     #$60
1301 E780             (fig-forth-auto680):00568                 STB     ,X+
1303 E780             (fig-forth-auto680):00569                 STB     ,X+
1305 E780             (fig-forth-auto680):00570                 STB     ,X+
1307 E780             (fig-forth-auto680):00571                 STB     ,X+
1309 E780             (fig-forth-auto680):00572                 STB     ,X+
130B C600             (fig-forth-auto680):00573                 LDB     #0
130D 1E9B             (fig-forth-auto680):00574                 EXG     B,DP
130F AD9FA000         (fig-forth-auto680):00575         DBGRkl  JSR     [$A000]
1313 27FA             (fig-forth-auto680):00576                 BEQ     DBGRkl
1315 FD043E           (fig-forth-auto680):00577                 STD     $43E
1318 1EB9             (fig-forth-auto680):00578                 EXG     DP,B
131A 8155             (fig-forth-auto680):00579                 CMPA    #$55    ; 'U'
131C 273C             (fig-forth-auto680):00580                 BEQ     DBGRdU
131E 8153             (fig-forth-auto680):00581                 CMPA    #$53    ; 'S'
1320 271E             (fig-forth-auto680):00582                 BEQ     DBGRdS
1322 8149             (fig-forth-auto680):00583                 CMPA    #$49    ; 'I'
1324 2647             (fig-forth-auto680):00584                 BNE     DBGRrt
1326 DC22             (fig-forth-auto680):00585         DBGRin  LDD     <XTIB
1328 D330             (fig-forth-auto680):00586                 ADDD    <XIN
132A 1F02             (fig-forth-auto680):00587                 TFR     D,Y
132C 17FF47           (fig-forth-auto680):00588                 LBSR    OUThxD
132F C63A             (fig-forth-auto680):00589                 LDB     #$3a    ; ':'
1331 E780             (fig-forth-auto680):00590                 STB     ,X+
1333 964C             (fig-forth-auto680):00591                 LDA     <XCOLUM
1335 E6A0             (fig-forth-auto680):00592         DBGRip  LDB     ,Y+
1337 E780             (fig-forth-auto680):00593                 STB     ,X+
1339 2732             (fig-forth-auto680):00594                 BEQ     DBGRrt
133B 4A               (fig-forth-auto680):00595         DBGRit  DECA
133C 26F7             (fig-forth-auto680):00596                 BNE     DBGRip
133E 202D             (fig-forth-auto680):00597                 BRA     DBGRrt
1340 1F42             (fig-forth-auto680):00598         DBGRdS  TFR     S,Y
1342 2009             (fig-forth-auto680):00599                 BRA     DBGRst
1344 ECA1             (fig-forth-auto680):00600         DBGRsp  LDD     ,Y++
1346 17FF2D           (fig-forth-auto680):00601                 LBSR    OUThxD
1349 C660             (fig-forth-auto680):00602                 LDB     #$60
134B E780             (fig-forth-auto680):00603                 STB     ,X+
134D 109C20           (fig-forth-auto680):00604         DBGRst  CMPY    <XRZERO
1350 25F2             (fig-forth-auto680):00605                 BLO     DBGRsp
1352 C63A             (fig-forth-auto680):00606                 LDB     #$3a    ; ':'
1354 E780             (fig-forth-auto680):00607                 STB     ,X+
1356 C655             (fig-forth-auto680):00608                 LDB     #$55
1358 E780             (fig-forth-auto680):00609                 STB     ,X+
135A 10AE68           (fig-forth-auto680):00610         DBGRdU  LDY     2*NATWID+4,S
135D 2009             (fig-forth-auto680):00611                 BRA     DBGRut
135F ECA1             (fig-forth-auto680):00612         DBGRup  LDD     ,Y++
1361 17FF12           (fig-forth-auto680):00613                 LBSR    OUThxD
1364 C660             (fig-forth-auto680):00614                 LDB     #$60
1366 E780             (fig-forth-auto680):00615                 STB     ,X+
1368 109C1E           (fig-forth-auto680):00616         DBGRut  CMPY    <XSPZER
136B 25F2             (fig-forth-auto680):00617                 BLO     DBGRup
136D 35FF             (fig-forth-auto680):00618         DBGRrt  PULS    CC,A,B,DP,X,Y,U,PC
136F 4450434320504320 (fig-forth-auto680):00619         DBGRLB  FCC     'DPCC PC   S   U    Y   X    A B '
     2020532020205520
     2020205920202058
     2020202041204220
138F 00000000         (fig-forth-auto680):00620                 FDB     0,0
                      (fig-forth-auto680):00621         
                      (fig-forth-auto680):00622         
                      (fig-forth-auto680):00623         *
                      (fig-forth-auto680):00624         *                                                                 =
                      (fig-forth-auto680):00625         * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
                      (fig-forth-auto680):00626         
                      (fig-forth-auto680):00627         
                      (fig-forth-auto680):00628                 PAGE
                      (fig-forth-auto680):00629         *
                      (fig-forth-auto680):00630         * ======>>  1  <<
                      (fig-forth-auto680):00631         * ( --- n )
                      (fig-forth-auto680):00632         * Pushes the following natural width integer from the instruction stream
                      (fig-forth-auto680):00633         * as a literal, or immediate value.
                      (fig-forth-auto680):00634         *
                      (fig-forth-auto680):00635         *       FDB {OP}
                      (fig-forth-auto680):00636         *       FDB {OP}
                      (fig-forth-auto680):00637         *       FDB LIT
                      (fig-forth-auto680):00638         *       FDB LITERAL-TO-BE-PUSHED
                      (fig-forth-auto680):00639         *       FDB {OP}
                      (fig-forth-auto680):00640         *
                      (fig-forth-auto680):00641         * In native processor code, there should be a better way, use that instead.
                      (fig-forth-auto680):00642         * More specifically, DO NOT CALL THIS from assembly language code.
                      (fig-forth-auto680):00643         * (Note that there is no compile-only flag in the fig model.)
                      (fig-forth-auto680):00644         *
                      (fig-forth-auto680):00645         * See (FIND), or PFIND , for layout of the header format.
                      (fig-forth-auto680):00646         *
1393 83               (fig-forth-auto680):00647                 FCB     $83
1394 4C49             (fig-forth-auto680):00648                 FCC     'LI'    ; 'LIT' :       NOTE: this is different from LITERAL
1396 D4               (fig-forth-auto680):00649                 FCB     $D4     ; 'T'|'\x80'    ; character code for T, with high bit set.
1397 0000             (fig-forth-auto680):00650                 FDB     0       ; link of zero to terminate dictionary scan
1399 139B             (fig-forth-auto680):00651         LIT     FDB     *+NATWID        ; Note also that LIT is meaningless in native code.
139B ECA1             (fig-forth-auto680):00652                 LDD     ,Y++
139D 3606             (fig-forth-auto680):00653                 PSHU    A,B
139F 39               (fig-forth-auto680):00654                 RTS
                      (fig-forth-auto680):00655         *       LDX     IP
                      (fig-forth-auto680):00656         *       LEAX 1,X        ; 
                      (fig-forth-auto680):00657         *       LEAX 1,X        ; 
                      (fig-forth-auto680):00658         *       STX     IP
                      (fig-forth-auto680):00659         *       LDA 0,X
                      (fig-forth-auto680):00660         *       LDB 1,X
                      (fig-forth-auto680):00661         *       JMP     PUSHBA
                      (fig-forth-auto680):00662         *
                      (fig-forth-auto680):00663         * ######>> screen 14 <<
                      (fig-forth-auto680):00664         * ======>>  2  <<
                      (fig-forth-auto680):00665         * ( --- n )
                      (fig-forth-auto680):00666         * Pushes the following byte from the instruction stream
                      (fig-forth-auto680):00667         * as a literal, or immediate value.
                      (fig-forth-auto680):00668         *
                      (fig-forth-auto680):00669         *       FDB {OP}
                      (fig-forth-auto680):00670         *       FDB {OP}
                      (fig-forth-auto680):00671         *       FDB LIT8
                      (fig-forth-auto680):00672         *       FCB LITERAL-TO-BE-PUSHED
                      (fig-forth-auto680):00673         *       FDB {OP}
                      (fig-forth-auto680):00674         *
                      (fig-forth-auto680):00675         * If this is kept, it should have a header for TRACE to read.
                      (fig-forth-auto680):00676         * If the data bus is wider than a byte, you don't want to do this.
                      (fig-forth-auto680):00677         * Byte shaving like this is often counter-productive anyway.
                      (fig-forth-auto680):00678         * Changing the name to LIT8, hoping that will be more understandable.
                      (fig-forth-auto680):00679         * Also, see comments for LIT.
                      (fig-forth-auto680):00680         * (Note that there is no compile-only flag in the fig model.)
13A0 84               (fig-forth-auto680):00681                 FCB     $84
13A1 4C4954           (fig-forth-auto680):00682                 FCC     'LIT'   ; 'LIT8' :      NOTE: this is different from LITERAL
13A4 B8               (fig-forth-auto680):00683                 FCB     $B8
13A5 1393             (fig-forth-auto680):00684                 FDB     LIT-6
13A7 13A9             (fig-forth-auto680):00685         LIT8    FDB     *+NATWID         (this was an invisible word, with no header)
13A9 E6A0             (fig-forth-auto680):00686                 LDB     ,Y+     ; This also is meaningless in native code.
13AB 4F               (fig-forth-auto680):00687                 CLRA
13AC 3606             (fig-forth-auto680):00688                 PSHU    A,B
13AE 39               (fig-forth-auto680):00689                 RTS
                      (fig-forth-auto680):00690         *       LDX     IP
                      (fig-forth-auto680):00691         *       LEAX 1,X        ; 
                      (fig-forth-auto680):00692         *       STX     IP
                      (fig-forth-auto680):00693         *       CLRA    ;
                      (fig-forth-auto680):00694         *       LDB 1,X
                      (fig-forth-auto680):00695         *       JMP     PUSHBA
                      (fig-forth-auto680):00696         *
                      (fig-forth-auto680):00697         * ( n off --- n )
                      (fig-forth-auto680):00698         * off is offset in video buffer area.
13AF 87               (fig-forth-auto680):00699                 FCB     $87
13B0 53484F57544F     (fig-forth-auto680):00700                 FCC     'SHOWTO'        ; 'SHOWTOS'
13B6 D3               (fig-forth-auto680):00701                 FCB     $D3     ; 'S'
13B7 13A0             (fig-forth-auto680):00702                 FDB     LIT8-7
13B9 13BB             (fig-forth-auto680):00703         SHOTOS  FDB     *+NATWID
13BB 8E0400           (fig-forth-auto680):00704                 LDX     #$400
13BE ECC1             (fig-forth-auto680):00705                 LDD     ,U++
13C0 308B             (fig-forth-auto680):00706                 LEAX    D,X
13C2 ECC4             (fig-forth-auto680):00707                 LDD     ,U
13C4 17FEAF           (fig-forth-auto680):00708                 LBSR    OUThxD
13C7 39               (fig-forth-auto680):00709                 RTS
                      (fig-forth-auto680):00710         *
13C8 85               (fig-forth-auto680):00711                 FCB     $85
13C9 54524F46         (fig-forth-auto680):00712                 FCC     'TROF'  ; 'TROFF'
13CD C6               (fig-forth-auto680):00713                 FCB     $C6     ; 'F'|$80
13CE 13AF             (fig-forth-auto680):00714                 FDB     SHOTOS-10
13D0 13D2             (fig-forth-auto680):00715         TROFF   FDB     *+NATWID
13D2 0F0B             (fig-forth-auto680):00716                 CLR     <TRACEM
13D4 39               (fig-forth-auto680):00717                 RTS
                      (fig-forth-auto680):00718         *
13D5 84               (fig-forth-auto680):00719                 FCB     $84
13D6 54524F           (fig-forth-auto680):00720                 FCC     'TRO'   ; 'TRON'
13D9 CE               (fig-forth-auto680):00721                 FCB     $CE     ; 'N'|$80
13DA 13C8             (fig-forth-auto680):00722                 FDB     TROFF-8
13DC 13DE             (fig-forth-auto680):00723         TRON    FDB     *+NATWID
13DE 0C0B             (fig-forth-auto680):00724                 INC     <TRACEM
13E0 39               (fig-forth-auto680):00725                 RTS
                      (fig-forth-auto680):00726         *
                      (fig-forth-auto680):00727         * ======>>  3  <<
                      (fig-forth-auto680):00728         * ( adr --- )
                      (fig-forth-auto680):00729         * Jump to address on stack.  Used by the "outer" interpreter to
                      (fig-forth-auto680):00730         * interactively invoke routines.  
                      (fig-forth-auto680):00731         * Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
13E1 87               (fig-forth-auto680):00732                 FCB     $87
13E2 455845435554     (fig-forth-auto680):00733                 FCC     'EXECUT'        ; 'EXECUTE'
13E8 C5               (fig-forth-auto680):00734                 FCB     $C5
13E9 13D5             (fig-forth-auto680):00735                 FDB     TRON-7
13EB 13ED             (fig-forth-auto680):00736         EXEC    FDB     *+NATWID
13ED 3710             (fig-forth-auto680):00737                 PULU    X       ; Gotta have W anyway, just in case.
13EF 6E94             (fig-forth-auto680):00738                 JMP     [,X]    ; Tail return.
                      (fig-forth-auto680):00739         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):00740         *       LDX     0,X     get code field address (CFA)
                      (fig-forth-auto680):00741         *       LEAS 1,S        ;               pop stack
                      (fig-forth-auto680):00742         *       LEAS 1,S        ; 
                      (fig-forth-auto680):00743         *       JMP     NEXT3
                      (fig-forth-auto680):00744         *
                      (fig-forth-auto680):00745         * ######>> screen 15 <<
                      (fig-forth-auto680):00746         * ======>>  4  <<
                      (fig-forth-auto680):00747         * ( --- )                                                 C
                      (fig-forth-auto680):00748         * Add the following word from the instruction stream to the
                      (fig-forth-auto680):00749         * instruction pointer (Y++).  Causes a program branch in Forth code stream.
                      (fig-forth-auto680):00750         *
                      (fig-forth-auto680):00751         * In native processor code, there should be a better way, use that instead.
                      (fig-forth-auto680):00752         * More specifically, DO NOT CALL THIS from assembly language code.
                      (fig-forth-auto680):00753         * This is only for Forth code stream.
                      (fig-forth-auto680):00754         * Also, see comments for LIT.
13F1 86               (fig-forth-auto680):00755                 FCB     $86
13F2 4252414E43       (fig-forth-auto680):00756                 FCC     'BRANC' ; 'BRANCH'
13F7 C8               (fig-forth-auto680):00757                 FCB     $C8
13F8 13E1             (fig-forth-auto680):00758                 FDB     EXEC-10
13FA 140F             (fig-forth-auto680):00759         BRAN    FDB     ZBYES   ; Go steal code in ZBRANCH
                      (fig-forth-auto680):00760         
                      (fig-forth-auto680):00761         * Moving code around to optimize the branch taking case in 0BRANCH.
13FC 3122             (fig-forth-auto680):00762         ZBNO    LEAY    NATWID,Y ;      No branch.
13FE 39               (fig-forth-auto680):00763                 RTS
                      (fig-forth-auto680):00764         * ======>>  5  <<
                      (fig-forth-auto680):00765         * ( f --- )                                               C
                      (fig-forth-auto680):00766         * BRANCH if flag is zero.
                      (fig-forth-auto680):00767         *
                      (fig-forth-auto680):00768         * In native processor code, there should be a better way, use that instead.
                      (fig-forth-auto680):00769         * More specifically, DO NOT CALL THIS from assembly language code.
                      (fig-forth-auto680):00770         * This is only for Forth code stream.
                      (fig-forth-auto680):00771         * Also, see comments for LIT.
13FF 87               (fig-forth-auto680):00772                 FCB     $87
1400 304252414E43     (fig-forth-auto680):00773                 FCC     '0BRANC'        ; '0BRANCH'
1406 C8               (fig-forth-auto680):00774                 FCB     $C8
1407 13F1             (fig-forth-auto680):00775                 FDB     BRAN-9
1409 140B             (fig-forth-auto680):00776         ZBRAN   FDB     *+NATWID
140B ECC1             (fig-forth-auto680):00777                 LDD     ,U++
140D 26ED             (fig-forth-auto680):00778                 BNE     ZBNO
140F ECA1             (fig-forth-auto680):00779         ZBYES   LDD     ,Y++
1411 31AB             (fig-forth-auto680):00780                 LEAY    D,Y     ; IP is postinc
1413 39               (fig-forth-auto680):00781                 RTS
                      (fig-forth-auto680):00782         *       PULS A  ; 
                      (fig-forth-auto680):00783         *       PULS B  ; 
                      (fig-forth-auto680):00784         *       PSHS B  ; ** emulating ABA:
                      (fig-forth-auto680):00785         *       ADDA ,S+        ; 
                      (fig-forth-auto680):00786         *       BNE     ZBNO
                      (fig-forth-auto680):00787         *       BCS     ZBNO
                      (fig-forth-auto680):00788         * ZBYES LDX     IP      Note: code is shared with BRANCH, (+LOOP), (LOOP)
                      (fig-forth-auto680):00789         *       LDB 3,X
                      (fig-forth-auto680):00790         *       LDA 2,X
                      (fig-forth-auto680):00791         *       ADDB IP+1
                      (fig-forth-auto680):00792         *       ADCA IP
                      (fig-forth-auto680):00793         *       STB IP+1
                      (fig-forth-auto680):00794         *       STA IP
                      (fig-forth-auto680):00795         *       JMP     NEXT
                      (fig-forth-auto680):00796         * ZBNO  LDX     IP      no branch. This code is shared with (+LOOP), (LOOP).
                      (fig-forth-auto680):00797         *       LEAX 1,X        ;               jump over branch delta
                      (fig-forth-auto680):00798         *       LEAX 1,X        ; 
                      (fig-forth-auto680):00799         *       STX     IP
                      (fig-forth-auto680):00800         *       JMP     NEXT
                      (fig-forth-auto680):00801         *
                      (fig-forth-auto680):00802         * ######>> screen 16 <<
                      (fig-forth-auto680):00803         * ======>>  6  <<
                      (fig-forth-auto680):00804         * ( --- )         ( limit index *** limit index+1)        C
                      (fig-forth-auto680):00805         *                 ( limit index *** )
                      (fig-forth-auto680):00806         * Counting loop primitive.  The counter and limit are the top two
                      (fig-forth-auto680):00807         * words on the return stack.  If the updated index/counter does
                      (fig-forth-auto680):00808         * not exceed the limit, a branch occurs.  If it does, the branch
                      (fig-forth-auto680):00809         * does not occur, and the index and limit are dropped from the
                      (fig-forth-auto680):00810         * return stack.
                      (fig-forth-auto680):00811         *
                      (fig-forth-auto680):00812         * In native processor code, there should be a better way, use that instead.
                      (fig-forth-auto680):00813         * More specifically, DO NOT CALL THIS from assembly language code.
                      (fig-forth-auto680):00814         * This is only for Forth code stream.
                      (fig-forth-auto680):00815         * Also, see comments for LIT.
1414 86               (fig-forth-auto680):00816                 FCB     $86
1415 284C4F4F50       (fig-forth-auto680):00817                 FCC     '(LOOP' ; '(LOOP)'
141A A9               (fig-forth-auto680):00818                 FCB     $A9
141B 13FF             (fig-forth-auto680):00819                 FDB     ZBRAN-10
141D 141F             (fig-forth-auto680):00820         XLOOP   FDB     *+NATWID
141F CC0001           (fig-forth-auto680):00821                 LDD     #1      ; Borrowing from BIF-6809.
1422 E362             (fig-forth-auto680):00822         XLOOPA  ADDD    NATWID,S        ; Dodge the return address.
1424 ED62             (fig-forth-auto680):00823                 STD     NATWID,S
1426 A364             (fig-forth-auto680):00824                 SUBD    2*NATWID,S
1428 2DE5             (fig-forth-auto680):00825                 BLT     ZBYES   ; signed
142A 3122             (fig-forth-auto680):00826         XLOOPN  LEAY    NATWID,Y
142C AEE4             (fig-forth-auto680):00827                 LDX     ,S      ; synthetic return
142E 3266             (fig-forth-auto680):00828                 LEAS    3*NATWID,S      ; Clean up the index and limit.
1430 6E84             (fig-forth-auto680):00829                 JMP     ,X      
                      (fig-forth-auto680):00830         *       CLRA    ;
                      (fig-forth-auto680):00831         *       LDB #1  get set to increment counter by 1 (Clears N.)
                      (fig-forth-auto680):00832         *       BRA     XPLOP2  go steal other guy's code!
                      (fig-forth-auto680):00833         *
                      (fig-forth-auto680):00834         * ======>>  7  <<
                      (fig-forth-auto680):00835         * ( n --- )       ( limit index *** limit index+n )       C
                      (fig-forth-auto680):00836         *                 ( limit index *** )
                      (fig-forth-auto680):00837         * Loop with a variable increment.  Terminates when the index
                      (fig-forth-auto680):00838         * crosses the boundary from one below the limit to the limit.  A
                      (fig-forth-auto680):00839         * positive n will cause termination if the result index equals the
                      (fig-forth-auto680):00840         * limit.  A negative n must cause the index to become less than
                      (fig-forth-auto680):00841         * the limit to cause loop termination.
                      (fig-forth-auto680):00842         *
                      (fig-forth-auto680):00843         * Note that the end conditions are not symmetric around zero.
                      (fig-forth-auto680):00844         *
                      (fig-forth-auto680):00845         * In native processor code, there should be a better way, use that instead.
                      (fig-forth-auto680):00846         * More specifically, DO NOT CALL THIS from assembly language code.
                      (fig-forth-auto680):00847         * This is only for Forth code stream.
                      (fig-forth-auto680):00848         * Also, see comments for LIT.
1432 87               (fig-forth-auto680):00849                 FCB     $87
1433 282B4C4F4F50     (fig-forth-auto680):00850                 FCC     '(+LOOP'        ; '(+LOOP)'
1439 A9               (fig-forth-auto680):00851                 FCB     $A9
143A 1414             (fig-forth-auto680):00852                 FDB     XLOOP-9
143C 143E             (fig-forth-auto680):00853         XPLOOP  FDB     *+NATWID        ; Borrowing from BIF-6809.
143E ECC1             (fig-forth-auto680):00854                 LDD     ,U++            ; inc val
1440 2AE0             (fig-forth-auto680):00855                 BPL     XLOOPA          ; Steal plain loop code for forward count.
1442 E362             (fig-forth-auto680):00856                 ADDD    NATWID,S                ; Dodge the return address
1444 ED62             (fig-forth-auto680):00857                 STD     NATWID,S
1446 A364             (fig-forth-auto680):00858                 SUBD    2*NATWID,S
1448 2EC5             (fig-forth-auto680):00859                 BGT     ZBYES           ; signed
144A 20DE             (fig-forth-auto680):00860                 BRA     XLOOPN          ; This path is less time-sensitive.
                      (fig-forth-auto680):00861         *
                      (fig-forth-auto680):00862         * This should work, but I want to use tested code.
                      (fig-forth-auto680):00863         *       PULU    A,B     ; Get the increment.
                      (fig-forth-auto680):00864         * XPLOP2        PULS    X       ; Pre-clear the return stack.
                      (fig-forth-auto680):00865         *       PSHU    A       ; Save the direction in high bit.       
                      (fig-forth-auto680):00866         *       ADDD    ,S      ; Count.
                      (fig-forth-auto680):00867         *       STD     ,S      ; Update.
                      (fig-forth-auto680):00868         *       SUBD    NATWID,S        ; Check limit.
                      (fig-forth-auto680):00869         **
                      (fig-forth-auto680):00870         ** I think this should work:
                      (fig-forth-auto680):00871         *       EORA    ,U+     ; dir < 0 and (count - limit) >= 0
                      (fig-forth-auto680):00872         *       BPL     XPLONO  ; or dir >= 0 and (count - limit) < 0
                      (fig-forth-auto680):00873         *       LDD     ,Y++
                      (fig-forth-auto680):00874         *       LEAY    D,Y     ; IP is postinc
                      (fig-forth-auto680):00875         *       JMP     ,X
                      (fig-forth-auto680):00876         * XPLONO        LEAS    2*NATWID,S
                      (fig-forth-auto680):00877         *       JMP     ,X      ; synthetic return
                      (fig-forth-auto680):00878         *
                      (fig-forth-auto680):00879         * This definitely should work:
                      (fig-forth-auto680):00880         *       TST     ,U+     ; Get the sign
                      (fig-forth-auto680):00881         *       BPL     XPLOF   ; 
                      (fig-forth-auto680):00882         *       CMPD    NATWID,S
                      (fig-forth-auto680):00883         *       BMI     XPLONO
                      (fig-forth-auto680):00884         * XPLOYE        LDD     ,Y++
                      (fig-forth-auto680):00885         *       LEAY    D,Y     ; IP is postinc
                      (fig-forth-auto680):00886         *       JMP     ,X
                      (fig-forth-auto680):00887         * XPLOF CMPD    NATWID,S
                      (fig-forth-auto680):00888         *       BMI     XPLOYE
                      (fig-forth-auto680):00889         * XPLONO        LEAS    2*NATWID,S
                      (fig-forth-auto680):00890         *       JMP     ,X      ; synthetic return
                      (fig-forth-auto680):00891         *
                      (fig-forth-auto680):00892         * 6800 Probably could have used the exclusive-or method, too.:
                      (fig-forth-auto680):00893         *       PULS A  ; get increment
                      (fig-forth-auto680):00894         *       PULS B  ; 
                      (fig-forth-auto680):00895         * XPLOP2        TSTA    ;
                      (fig-forth-auto680):00896         *       BPL     XPLOF   forward looping
                      (fig-forth-auto680):00897         *       BSR     XPLOPS
                      (fig-forth-auto680):00898         *       ORCC #$01       ; SEC : 
                      (fig-forth-auto680):00899         *       SBCB 5,X
                      (fig-forth-auto680):00900         *       SBCA 4,X
                      (fig-forth-auto680):00901         *       BPL     ZBYES
                      (fig-forth-auto680):00902         *       BRA     XPLONO  fall through
                      (fig-forth-auto680):00903         *
                      (fig-forth-auto680):00904         * the subroutine :
                      (fig-forth-auto680):00905         * XPLOPS        LDX     RP
                      (fig-forth-auto680):00906         *       ADDB 3,X        add it to counter
                      (fig-forth-auto680):00907         *       ADCA 2,X
                      (fig-forth-auto680):00908         *       STB 3,X store new counter value
                      (fig-forth-auto680):00909         *       STA 2,X
                      (fig-forth-auto680):00910         *       RTS
                      (fig-forth-auto680):00911         *
                      (fig-forth-auto680):00912         * XPLOF BSR     XPLOPS
                      (fig-forth-auto680):00913         *       SUBB 5,X
                      (fig-forth-auto680):00914         *       SBCA 4,X
                      (fig-forth-auto680):00915         *       BMI     ZBYES
                      (fig-forth-auto680):00916         *
                      (fig-forth-auto680):00917         * XPLONO        LEAX 1,X        ;               done, don't branch back
                      (fig-forth-auto680):00918         *       LEAX 1,X        ; 
                      (fig-forth-auto680):00919         *       LEAX 1,X        ; 
                      (fig-forth-auto680):00920         *       LEAX 1,X        ; 
                      (fig-forth-auto680):00921         *       STX     RP
                      (fig-forth-auto680):00922         *       BRA     ZBNO    use ZBRAN to skip over unused delta
                      (fig-forth-auto680):00923         *
                      (fig-forth-auto680):00924         * ######>> screen 17 <<
                      (fig-forth-auto680):00925         * ======>>  8  <<
                      (fig-forth-auto680):00926         * ( limit index --- )     ( *** limit index )
                      (fig-forth-auto680):00927         * Move the loop parameters to the return stack.  Synonym for D>R.
144C 84               (fig-forth-auto680):00928                 FCB     $84
144D 28444F           (fig-forth-auto680):00929                 FCC     '(DO'   ; '(DO)'
1450 A9               (fig-forth-auto680):00930                 FCB     $A9
1451 1432             (fig-forth-auto680):00931                 FDB     XPLOOP-10
1453 1455             (fig-forth-auto680):00932         XDO     FDB     *+NATWID        This is the RUNTIME DO, not the COMPILING DO
1455 AEE4             (fig-forth-auto680):00933                 LDX     ,S      ; Save the return address.
1457 3706             (fig-forth-auto680):00934                 PULU    A,B
1459 3406             (fig-forth-auto680):00935                 PSHS    A,B
145B 3706             (fig-forth-auto680):00936                 PULU    A,B     ; Maintain order.
145D ED62             (fig-forth-auto680):00937                 STD     NATWID,S
145F 6E84             (fig-forth-auto680):00938                 JMP     ,X      ; synthetic return
                      (fig-forth-auto680):00939         *
                      (fig-forth-auto680):00940         *       LDX     RP
                      (fig-forth-auto680):00941         *       LEAX -1,X       ; 
                      (fig-forth-auto680):00942         *       LEAX -1,X       ; 
                      (fig-forth-auto680):00943         *       LEAX -1,X       ; 
                      (fig-forth-auto680):00944         *       LEAX -1,X       ; 
                      (fig-forth-auto680):00945         *       STX     RP
                      (fig-forth-auto680):00946         *       PULS A  ; 
                      (fig-forth-auto680):00947         *       PULS B  ; 
                      (fig-forth-auto680):00948         *       STA 2,X
                      (fig-forth-auto680):00949         *       STB 3,X
                      (fig-forth-auto680):00950         *       PULS A  ; 
                      (fig-forth-auto680):00951         *       PULS B  ; 
                      (fig-forth-auto680):00952         *       STA 4,X
                      (fig-forth-auto680):00953         *       STB 5,X
                      (fig-forth-auto680):00954         *       JMP     NEXT
                      (fig-forth-auto680):00955         *
                      (fig-forth-auto680):00956         * ======>>  9  <<
                      (fig-forth-auto680):00957         * ( --- index )           ( limit index *** limit index )
                      (fig-forth-auto680):00958         * Copy the loop index from the return stack.  Synonym for R.
1461 81               (fig-forth-auto680):00959                 FCB     $81     I
1462 C9               (fig-forth-auto680):00960                 FCB     $C9
1463 144C             (fig-forth-auto680):00961                 FDB     XDO-7   
1465 1467             (fig-forth-auto680):00962         I       FDB     *+NATWID
1467 EC62             (fig-forth-auto680):00963                 LDD     NATWID,S        ; Dodge return address.
1469 3606             (fig-forth-auto680):00964                 PSHU    A,B
146B 39               (fig-forth-auto680):00965                 RTS
                      (fig-forth-auto680):00966         *       LDX     RP
                      (fig-forth-auto680):00967         *       LEAX 1,X        ; 
                      (fig-forth-auto680):00968         *       LEAX 1,X        ; 
                      (fig-forth-auto680):00969         *       JMP     GETX
                      (fig-forth-auto680):00970         *
                      (fig-forth-auto680):00971         * ######>> screen 18 <<
                      (fig-forth-auto680):00972         * ======>>  10  <<
                      (fig-forth-auto680):00973         * ( c base --- false )
                      (fig-forth-auto680):00974         * ( c base --- n true )
                      (fig-forth-auto680):00975         * Translate C in base, yielding a translation valid flag.  If the
                      (fig-forth-auto680):00976         * translation is not valid in the specified base, only the false
                      (fig-forth-auto680):00977         * flag is returned.
146C 85               (fig-forth-auto680):00978                 FCB     $85
146D 44494749         (fig-forth-auto680):00979                 FCC     'DIGI'  ; 'DIGIT'
1471 D4               (fig-forth-auto680):00980                 FCB     $D4
1472 1461             (fig-forth-auto680):00981                 FDB     I-4
1474 1476             (fig-forth-auto680):00982         DIGIT   FDB     *+NATWID        NOTE: legal input range is 0-9, A-Z
1476 EC42             (fig-forth-auto680):00983                 LDD     NATWID,U        ; Check the whole thing.
1478 830030           (fig-forth-auto680):00984                 SUBD    #$30    ; ascii zero
147B 2B22             (fig-forth-auto680):00985                 BMI     DIGIT2  IF LESS THAN '0', ILLEGAL
147D 1083000A         (fig-forth-auto680):00986                 CMPD    #$A
1481 2B0F             (fig-forth-auto680):00987                 BMI     DIGIT0  IF '9' OR LESS
1483 10830011         (fig-forth-auto680):00988                 CMPD    #$11
1487 2B16             (fig-forth-auto680):00989                 BMI     DIGIT2  if less than 'A'
1489 1083002B         (fig-forth-auto680):00990                 CMPD    #$2B
148D 2A10             (fig-forth-auto680):00991                 BPL     DIGIT2  if greater than 'Z'
148F 830007           (fig-forth-auto680):00992                 SUBD    #7      translate 'A' thru 'F'
1492 10A3C4           (fig-forth-auto680):00993         DIGIT0  CMPD    ,U      ; Check the base.
1495 2A08             (fig-forth-auto680):00994                 BPL     DIGIT2  if not less than the base
1497 ED42             (fig-forth-auto680):00995                 STD     NATWID,U        ; Store converted digit. (High byte known zero.)
1499 CC0001           (fig-forth-auto680):00996                 LDD     #1      ; set valid flag 
149C EDC4             (fig-forth-auto680):00997         DIGIT1  STD     ,U      ; store the flag
149E 39               (fig-forth-auto680):00998                 RTS     NEXT
149F CC0000           (fig-forth-auto680):00999         DIGIT2  LDD     #0      ; set not valid flag
14A2 3342             (fig-forth-auto680):01000                 LEAU    NATWID,U        ; pop base
14A4 20F6             (fig-forth-auto680):01001                 BRA     DIGIT1
                      (fig-forth-auto680):01002         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):01003         *       LDA 3,X
                      (fig-forth-auto680):01004         *       SUBA #$30       ascii zero
                      (fig-forth-auto680):01005         *       BMI     DIGIT2  IF LESS THAN '0', ILLEGAL
                      (fig-forth-auto680):01006         *       CMPA #$A
                      (fig-forth-auto680):01007         *       BMI     DIGIT0  IF '9' OR LESS
                      (fig-forth-auto680):01008         *       CMPA #$11
                      (fig-forth-auto680):01009         *       BMI     DIGIT2  if less than 'A'
                      (fig-forth-auto680):01010         *       CMPA #$2B
                      (fig-forth-auto680):01011         *       BPL     DIGIT2  if greater than 'Z'
                      (fig-forth-auto680):01012         *       SUBA #7 translate 'A' thru 'F'
                      (fig-forth-auto680):01013         * DIGIT0        CMPA 1,X
                      (fig-forth-auto680):01014         *       BPL     DIGIT2  if not less than the base
                      (fig-forth-auto680):01015         *       LDB #1  set flag
                      (fig-forth-auto680):01016         *       STA 3,X store digit
                      (fig-forth-auto680):01017         * DIGIT1        STB 1,X store the flag
                      (fig-forth-auto680):01018         *       JMP     NEXT
                      (fig-forth-auto680):01019         * DIGIT2        CLRB    ;
                      (fig-forth-auto680):01020         *       LEAS 1,S        ; 
                      (fig-forth-auto680):01021         *       LEAS 1,S        ;       pop bottom number
                      (fig-forth-auto680):01022         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):01023         *       STB 0,X make sure both bytes are 00
                      (fig-forth-auto680):01024         *       BRA     DIGIT1
                      (fig-forth-auto680):01025         *
                      (fig-forth-auto680):01026         * ######>> screen 19 <<
                      (fig-forth-auto680):01027         *
                      (fig-forth-auto680):01028         * The word definition format in the dictionary:
                      (fig-forth-auto680):01029         *
                      (fig-forth-auto680):01030         * (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
                      (fig-forth-auto680):01031         *
                      (fig-forth-auto680):01032         * NFA (name field address):
                      (fig-forth-auto680):01033         * char-count + $80      Length of symbol name, flagged with high bit set.
                      (fig-forth-auto680):01034         * char 1                Characters of symbol name.
                      (fig-forth-auto680):01035         * char 2
                      (fig-forth-auto680):01036         * ...
                      (fig-forth-auto680):01037         * char n  + $80      symbol termination flag (char set < 128 code points)
                      (fig-forth-auto680):01038         * LFA (link field address):
                      (fig-forth-auto680):01039         * link high byte \___pointer to previous word in list
                      (fig-forth-auto680):01040         * link low  byte /   -- Combined allocation/dictionary list. --
                      (fig-forth-auto680):01041         * CFA (code field address):
                      (fig-forth-auto680):01042         * CFA  high byte \___pointer to native CPU machine code
                      (fig-forth-auto680):01043         * CFA  low  byte /   -- Consider this the characteristic code. --
                      (fig-forth-auto680):01044         * PFA (parameter field address):
                      (fig-forth-auto680):01045         * parameter fields   -- Machine code for low-level native machine CPU code,
                      (fig-forth-auto680):01046         *    "                  instruction list for high-level Forth code,
                      (fig-forth-auto680):01047         *    "                  constant data for constants, pointers to per task variables,
                      (fig-forth-auto680):01048         *    "                  space for variables, for global variables, etc.
                      (fig-forth-auto680):01049         *
                      (fig-forth-auto680):01050         * In the case of native CPU machine code, the address at CFA will be PFA.
                      (fig-forth-auto680):01051         
                      (fig-forth-auto680):01052         * Definition attributes:
     0040             (fig-forth-auto680):01053         FIMMED  EQU     $40     ; Immediate word flag.
     0020             (fig-forth-auto680):01054         FSMUDG  EQU     $20     ; Smudged => definition not ready.
     003F             (fig-forth-auto680):01055         CTMASK  EQU     ($FF&(^($80|FIMMED)))   ; For unmasking the length byte.
                      (fig-forth-auto680):01056         * Note that the SMUDGE bit is not masked out.
                      (fig-forth-auto680):01057         *
                      (fig-forth-auto680):01058         * But we really want more (Thinking for a new model, need one more byte):
                      (fig-forth-auto680):01059         * FCOMPI        EQU     $10     ; Compile-time-only.
                      (fig-forth-auto680):01060         * FASSEM        EQU     $08     ; Assembly-language code only.
                      (fig-forth-auto680):01061         * F4THLV        EQU     $04     ; Must not be called from assembly language code.
                      (fig-forth-auto680):01062         * These would require some significant adjustments to the model.
                      (fig-forth-auto680):01063         * We also want to put the low-level VM stuff in its own vocabulary.
                      (fig-forth-auto680):01064         *
                      (fig-forth-auto680):01065         * ======>>  11  <<
                      (fig-forth-auto680):01066         * (FIND)  ( name vocptr --- locptr length true )
                      (fig-forth-auto680):01067         *         ( name vocptr --- false )
                      (fig-forth-auto680):01068         * Search vocabulary for a symbol called name. 
                      (fig-forth-auto680):01069         * name is a pointer to a high-bit bracket string with length head.
                      (fig-forth-auto680):01070         * vocptr is a pointer to the NFA of the tail-end (LATEST) definition 
                      (fig-forth-auto680):01071         * in the vocabulary to be searched.
                      (fig-forth-auto680):01072         * Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
14A6 86               (fig-forth-auto680):01073                 FCB     $86
14A7 2846494E44       (fig-forth-auto680):01074                 FCC     '(FIND' ; '(FIND)'
14AC A9               (fig-forth-auto680):01075                 FCB     $A9
14AD 146C             (fig-forth-auto680):01076                 FDB     DIGIT-8
14AF 14B1             (fig-forth-auto680):01077         PFIND   FDB     *+NATWID
14B1 3420             (fig-forth-auto680):01078                 PSHS    Y       ; Have to track two pointers.
                      (fig-forth-auto680):01079         * Use the stack and registers instead of temp area N.
     0002             (fig-forth-auto680):01080         PA0     EQU     NATWID  ; pointer to the length byte of name being searched against
     0000             (fig-forth-auto680):01081         PD      EQU     0       ; pointer to NFA of dict word being checked
                      (fig-forth-auto680):01082         *
                      (fig-forth-auto680):01083         *       INC     <TRACEM
                      (fig-forth-auto680):01084         *       LBSR    DBGREG
14B3 AEC4             (fig-forth-auto680):01085                 LDX     PD,U    ; Start in on the vocabulary (NFA).
14B5 10AE42           (fig-forth-auto680):01086         PFNDLP  LDY     PA0,U   ; Point to the name to check against.
14B8 E680             (fig-forth-auto680):01087                 LDB     ,X+     ; get dict name length byte
14BA 1F98             (fig-forth-auto680):01088                 TFR     B,A     ; Save it in case it matches.
14BC C43F             (fig-forth-auto680):01089                 ANDB    #CTMASK 
                      (fig-forth-auto680):01090         *       LBSR    DBGREG
14BE E1A0             (fig-forth-auto680):01091                 CMPB    ,Y+     ; Compare lengths
                      (fig-forth-auto680):01092         *       LBSR    DBGREG
14C0 261C             (fig-forth-auto680):01093                 BNE     PFNDUN
14C2 E680             (fig-forth-auto680):01094         PFNDBR  LDB     ,X+
14C4 5D               (fig-forth-auto680):01095                 TSTB    ;       ; Is high bit of character in dictionary entry set?
                      (fig-forth-auto680):01096         *       LBSR    DBGREG
14C5 2A13             (fig-forth-auto680):01097                 BPL     PFNDCH
                      (fig-forth-auto680):01098         *       LBSR    DBGREG
14C7 C47F             (fig-forth-auto680):01099                 ANDB    #$7F    ; Clear high bit from dictionary.
14C9 E1A0             (fig-forth-auto680):01100                 CMPB    ,Y+     ; Compare "last" characters.
                      (fig-forth-auto680):01101         *       LBSR    DBGREG
14CB 2717             (fig-forth-auto680):01102                 BEQ     FOUND   ; Matches even if dictionary actual length is shorter.
14CD AE81             (fig-forth-auto680):01103         PFNDLN  LDX     ,X++    ; Get previous link in vocabulary.
                      (fig-forth-auto680):01104         *       LBSR    DBGREG
14CF 26E4             (fig-forth-auto680):01105                 BNE     PFNDLP  ; Continue if link not=0
                      (fig-forth-auto680):01106         *
                      (fig-forth-auto680):01107         *       not found :
14D1 3342             (fig-forth-auto680):01108                 LEAU    NATWID,U        ; Return only false flag.
14D3 CC0000           (fig-forth-auto680):01109                 LDD     #0
14D6 EDC4             (fig-forth-auto680):01110                 STD     ,U
                      (fig-forth-auto680):01111         *       LBSR    DBGREG
                      (fig-forth-auto680):01112         *       DEC     <TRACEM
14D8 35A0             (fig-forth-auto680):01113                 PULS    Y,PC
                      (fig-forth-auto680):01114         *
14DA E1A0             (fig-forth-auto680):01115         PFNDCH  CMPB    ,Y+     ; Compare characters.
                      (fig-forth-auto680):01116         *       LBSR    DBGREG
14DC 27E4             (fig-forth-auto680):01117                 BEQ     PFNDBR
14DE                  (fig-forth-auto680):01118         PFNDUN  
14DE E680             (fig-forth-auto680):01119         PFNDSC  LDB     ,X+     ; scan forward to end of this name in dictionary
                      (fig-forth-auto680):01120         *       LBSR    DBGREG
14E0 2AFC             (fig-forth-auto680):01121                 BPL     PFNDSC
                      (fig-forth-auto680):01122         *       LBSR    DBGREG
14E2 20E9             (fig-forth-auto680):01123                 BRA     PFNDLN
                      (fig-forth-auto680):01124         *
                      (fig-forth-auto680):01125         *       found :
                      (fig-forth-auto680):01126         *
14E4 3004             (fig-forth-auto680):01127         FOUND   LEAX    2*NATWID,X
                      (fig-forth-auto680):01128         *       LBSR    DBGREG
14E6 AF42             (fig-forth-auto680):01129                 STX     NATWID,U
14E8 1F89             (fig-forth-auto680):01130                 TFR     A,B
14EA 4F               (fig-forth-auto680):01131                 CLRA
14EB EDC4             (fig-forth-auto680):01132                 STD     ,U
                      (fig-forth-auto680):01133         *       LBSR    DBGREG
14ED C601             (fig-forth-auto680):01134                 LDB     #1
14EF 3606             (fig-forth-auto680):01135                 PSHU    A,B
                      (fig-forth-auto680):01136         *       LBSR    DBGREG
                      (fig-forth-auto680):01137         *       DEC     <TRACEM
14F1 35A0             (fig-forth-auto680):01138                 PULS    Y,PC
                      (fig-forth-auto680):01139         *
                      (fig-forth-auto680):01140         * 6800 model:
                      (fig-forth-auto680):01141         *       NOP     ; Probably leftovers from a debugging session.
                      (fig-forth-auto680):01142         *       NOP
                      (fig-forth-auto680):01143         * PD    EQU     N       ptr to dict word being checked
                      (fig-forth-auto680):01144         * PA0   EQU     N+2
                      (fig-forth-auto680):01145         * PA    EQU     N+4
                      (fig-forth-auto680):01146         * PC    EQU     N+6
                      (fig-forth-auto680):01147         *       LDX     #PD
                      (fig-forth-auto680):01148         *       LDB #4
                      (fig-forth-auto680):01149         * PFIND0        PULS A  ; loop to get arguments
                      (fig-forth-auto680):01150         *       STA 0,X
                      (fig-forth-auto680):01151         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01152         *       DECB    ;
                      (fig-forth-auto680):01153         *       BNE     PFIND0
                      (fig-forth-auto680):01154         *
                      (fig-forth-auto680):01155         *       LDX     PD
                      (fig-forth-auto680):01156         * PFNDLP        LDB 0,X get count dict count
                      (fig-forth-auto680):01157         *       STB PC
                      (fig-forth-auto680):01158         *       ANDB #$3F
                      (fig-forth-auto680):01159         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01160         *       STX     PD      update PD
                      (fig-forth-auto680):01161         *       LDX     PA0
                      (fig-forth-auto680):01162         *       LDA 0,X get count from arg
                      (fig-forth-auto680):01163         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01164         *       STX     PA      intialize PA
                      (fig-forth-auto680):01165         *       PSHS B  ; ** emulating CBA:
                      (fig-forth-auto680):01166         *       CMPA ,S+        ;               compare lengths
                      (fig-forth-auto680):01167         *       BNE     PFNDUN
                      (fig-forth-auto680):01168         * PFNDBR        LDX     PA
                      (fig-forth-auto680):01169         *       LDA 0,X
                      (fig-forth-auto680):01170         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01171         *       STX     PA
                      (fig-forth-auto680):01172         *       LDX     PD
                      (fig-forth-auto680):01173         *       LDB 0,X
                      (fig-forth-auto680):01174         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01175         *       STX     PD
                      (fig-forth-auto680):01176         *       TSTB    ;               is dict entry neg. ?
                      (fig-forth-auto680):01177         *       BPL     PFNDCH
                      (fig-forth-auto680):01178         *       ANDB #$7F       clear sign
                      (fig-forth-auto680):01179         *       PSHS B  ; ** emulating CBA:
                      (fig-forth-auto680):01180         *       CMPA ,S+        ; 
                      (fig-forth-auto680):01181         *       BEQ     FOUND
                      (fig-forth-auto680):01182         * PFNDLN        LDX     0,X     get new link
                      (fig-forth-auto680):01183         *       BNE     PFNDLP  continue if link not=0
                      (fig-forth-auto680):01184         *
                      (fig-forth-auto680):01185         *       not found :
                      (fig-forth-auto680):01186         *
                      (fig-forth-auto680):01187         *       CLRA    ;
                      (fig-forth-auto680):01188         *       CLRB    ;
                      (fig-forth-auto680):01189         *       JMP     PUSHBA
                      (fig-forth-auto680):01190         * PFNDCH        PSHS B  ; ** emulating CBA:
                      (fig-forth-auto680):01191         *       CMPA ,S+        ; 
                      (fig-forth-auto680):01192         *       BEQ     PFNDBR
                      (fig-forth-auto680):01193         * PFNDUN        LDX     PD
                      (fig-forth-auto680):01194         * PFNDSC        LDB 0,X scan forward to end of this name
                      (fig-forth-auto680):01195         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01196         *       BPL     PFNDSC
                      (fig-forth-auto680):01197         *       BRA     PFNDLN
                      (fig-forth-auto680):01198         *
                      (fig-forth-auto680):01199         *       found :
                      (fig-forth-auto680):01200         *
                      (fig-forth-auto680):01201         * FOUND LDA PD  compute CFA
                      (fig-forth-auto680):01202         *       LDB PD+1
                      (fig-forth-auto680):01203         *       ADDB #4
                      (fig-forth-auto680):01204         *       ADCA #0
                      (fig-forth-auto680):01205         *       PSHS B  ; 
                      (fig-forth-auto680):01206         *       PSHS A  ; 
                      (fig-forth-auto680):01207         *       LDA PC
                      (fig-forth-auto680):01208         *       PSHS A  ; 
                      (fig-forth-auto680):01209         *       CLRA    ;
                      (fig-forth-auto680):01210         *       PSHS A  ; 
                      (fig-forth-auto680):01211         *       LDB #1
                      (fig-forth-auto680):01212         *       JMP     PUSHBA
                      (fig-forth-auto680):01213         *
                      (fig-forth-auto680):01214         *       PSHS A  ; Left over from a stray copy-paste, I guess.
                      (fig-forth-auto680):01215         *       CLRA    ;
                      (fig-forth-auto680):01216         *       PSHS A  ; 
                      (fig-forth-auto680):01217         *       LDB #1
                      (fig-forth-auto680):01218         *       JMP     PUSHBA
                      (fig-forth-auto680):01219         *
                      (fig-forth-auto680):01220         * ######>> screen 20 <<
                      (fig-forth-auto680):01221         * ======>>  12  <<
                      (fig-forth-auto680):01222         * ( buffer ch --- buffer symboloffset delimiteroffset scancount )
                      (fig-forth-auto680):01223         * ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
                      (fig-forth-auto680):01224         * ( buffer ch --- buffer nuloffset onepast scancount )
                      (fig-forth-auto680):01225         * Scan buffer for a symbol delimited by ch or ASCII NUL, 
                      (fig-forth-auto680):01226         * return the length of the buffer region scanned,
                      (fig-forth-auto680):01227         * the offset to the trailing delimiter,
                      (fig-forth-auto680):01228         * and the offset of the first character of the symbol. 
                      (fig-forth-auto680):01229         * Leave the buffer on the stack.
                      (fig-forth-auto680):01230         * Scancount is also offset to first character not yet looked at.
                      (fig-forth-auto680):01231         * If no symbol in buffer, scancount and symboloffset point to NUL
                      (fig-forth-auto680):01232         * and delimiteroffset points one beyond for some reason. 
                      (fig-forth-auto680):01233         * On trailing NUL, delimiteroffset == scancount.
                      (fig-forth-auto680):01234         * (Buffer is the address of the buffer array to scan.)
                      (fig-forth-auto680):01235         * (This is a bit too tricky, really.)
14F3 87               (fig-forth-auto680):01236                 FCB     $87
14F4 454E434C4F53     (fig-forth-auto680):01237                 FCC     'ENCLOS'        ; 'ENCLOSE'
14FA C5               (fig-forth-auto680):01238                 FCB     $C5
14FB 14A6             (fig-forth-auto680):01239                 FDB     PFIND-9
14FD 14FF             (fig-forth-auto680):01240         ENCLOS  FDB     *+NATWID
14FF A641             (fig-forth-auto680):01241                 LDA     1,U     ; Delimiter character to match against in A.
1501 AE42             (fig-forth-auto680):01242                 LDX     NATWID,U        ; Buffer to scan in.
1503 5F               (fig-forth-auto680):01243                 CLRB            ; Initialize offset. (Buffer < 256 wide!)
                      (fig-forth-auto680):01244         *       Scan to a non-delimiter or a NUL
1504 6D85             (fig-forth-auto680):01245         ENCDEL  TST     B,X     ; NUL ?
1506 271F             (fig-forth-auto680):01246                 BEQ     ENCNUL
1508 A185             (fig-forth-auto680):01247                 CMPA    B,X     ; Delimiter?
150A 2603             (fig-forth-auto680):01248                 BNE     ENC1ST
150C 5C               (fig-forth-auto680):01249                 INCB            ; count character
150D 20F5             (fig-forth-auto680):01250                 BRA     ENCDEL
                      (fig-forth-auto680):01251         *       Found first character. Save the offset.
150F E741             (fig-forth-auto680):01252         ENC1ST  STB     1,U     ; Found first non-delimiter character --
1511 6FC4             (fig-forth-auto680):01253                 CLR     ,U      ; store the count, zero high byte.
                      (fig-forth-auto680):01254         *       Scan to a delimiter or a NUL
1513 6D85             (fig-forth-auto680):01255         ENCSYM  TST     B,X     ; NUL ?
1515 271E             (fig-forth-auto680):01256                 BEQ     ENC0TR
1517 A185             (fig-forth-auto680):01257                 CMPA    B,X     ; delimiter?
1519 2703             (fig-forth-auto680):01258                 BEQ     ENCEND
151B 5C               (fig-forth-auto680):01259                 INCB
151C 20F5             (fig-forth-auto680):01260                 BRA     ENCSYM
                      (fig-forth-auto680):01261         *       Found end of symbol. Push offset to delimiter found.
151E 4F               (fig-forth-auto680):01262         ENCEND  CLRA            ; high byte -- buffer < 255 wide!
151F 3606             (fig-forth-auto680):01263                 PSHU    A,B     ; Offset to seen delimiter.
                      (fig-forth-auto680):01264         *       Advance and push address of next character to check.
1521 C30001           (fig-forth-auto680):01265                 ADDD    #1      ; In case offset was 255.
1524 3606             (fig-forth-auto680):01266                 PSHU    A,B
1526 39               (fig-forth-auto680):01267                 RTS
                      (fig-forth-auto680):01268         *       Found NUL before non-delimiter, therefore there is no word
1527 4F               (fig-forth-auto680):01269         ENCNUL  CLRA            ; high byte -- buffer < 255 wide!
1528 EDC4             (fig-forth-auto680):01270                 STD     ,U      ; offset to NUL.
152A C30001           (fig-forth-auto680):01271                 ADDD    #1      ; Point after NUL to allow (FIND) to match it.
152D 3606             (fig-forth-auto680):01272                 PSHU    A,B     ;
152F 830001           (fig-forth-auto680):01273                 SUBD    #1      ; Next is not passed NUL.
1532 3606             (fig-forth-auto680):01274                 PSHU    A,B     ; Stealing code will save only one byte.
1534 39               (fig-forth-auto680):01275                 RTS
                      (fig-forth-auto680):01276         *       Found NUL following the word instead of delimiter.
1535                  (fig-forth-auto680):01277         ENC0TR
                      (fig-forth-auto680):01278         *       INC     <TRACEM
                      (fig-forth-auto680):01279         *       LBSR    DBGREG
1535 4F               (fig-forth-auto680):01280                 CLRA
1536 3606             (fig-forth-auto680):01281                 PSHU    A,B     ; Save offset to first after symbol (NUL)
                      (fig-forth-auto680):01282         *       LBSR    DBGREG
1538 3606             (fig-forth-auto680):01283                 PSHU    A,B     ; and count scanned.
                      (fig-forth-auto680):01284         *       LBSR    DBGREG
                      (fig-forth-auto680):01285         *       DEC     <TRACEM
153A 39               (fig-forth-auto680):01286                 RTS
                      (fig-forth-auto680):01287         * NOTE :
                      (fig-forth-auto680):01288         * FC means offset (bytes) to First Character of next word
                      (fig-forth-auto680):01289         * EW  "     "   to End of Word
                      (fig-forth-auto680):01290         * NC  "     "   to Next Character to start next enclose at
                      (fig-forth-auto680):01291         * ENCLOS        FDB     *+NATWID
                      (fig-forth-auto680):01292         *       LEAS 1,S        ; 
                      (fig-forth-auto680):01293         *       PULS B  ; now, get the low byte, for an 8-bit delimiter
                      (fig-forth-auto680):01294         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):01295         *       LDX     0,X
                      (fig-forth-auto680):01296         *       CLR N
                      (fig-forth-auto680):01297         * *     wait for a non-delimiter or a NUL
                      (fig-forth-auto680):01298         * ENCDEL        LDA 0,X
                      (fig-forth-auto680):01299         *       BEQ     ENCNUL
                      (fig-forth-auto680):01300         *       PSHS B  ; ** emulating CBA:
                      (fig-forth-auto680):01301         *       CMPA ,S+        ;               CHECK FOR DELIM
                      (fig-forth-auto680):01302         *       BNE     ENC1ST
                      (fig-forth-auto680):01303         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01304         *       INC N
                      (fig-forth-auto680):01305         *       BRA     ENCDEL
                      (fig-forth-auto680):01306         * *     found first character. Push FC
                      (fig-forth-auto680):01307         * ENC1ST        LDA N   found first char.
                      (fig-forth-auto680):01308         *       PSHS A  ; 
                      (fig-forth-auto680):01309         *       CLRA    ;
                      (fig-forth-auto680):01310         *       PSHS A  ; 
                      (fig-forth-auto680):01311         *       wait for a delimiter or a NUL
                      (fig-forth-auto680):01312         * ENCSYM        LDA 0,X
                      (fig-forth-auto680):01313         *       BEQ     ENC0TR
                      (fig-forth-auto680):01314         *       PSHS B  ; ** emulating CBA:
                      (fig-forth-auto680):01315         *       CMPA ,S+        ;               ckech for delim.
                      (fig-forth-auto680):01316         *       BEQ     ENCEND
                      (fig-forth-auto680):01317         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01318         *       INC N
                      (fig-forth-auto680):01319         *       BRA     ENCSYM
                      (fig-forth-auto680):01320         * *     found EW. Push it
                      (fig-forth-auto680):01321         * ENCEND        LDB N
                      (fig-forth-auto680):01322         *       CLRA    ;
                      (fig-forth-auto680):01323         *       PSHS B  ; 
                      (fig-forth-auto680):01324         *       PSHS A  ; 
                      (fig-forth-auto680):01325         * *     advance and push NC
                      (fig-forth-auto680):01326         *       INCB    ;
                      (fig-forth-auto680):01327         *       JMP     PUSHBA
                      (fig-forth-auto680):01328         *       found NUL before non-delimiter, therefore there is no word
                      (fig-forth-auto680):01329         * ENCNUL        LDB N   found NUL
                      (fig-forth-auto680):01330         *       PSHS B  ; 
                      (fig-forth-auto680):01331         *       PSHS A  ; 
                      (fig-forth-auto680):01332         *       INCB    ;
                      (fig-forth-auto680):01333         *       BRA     ENC0TR+2        ; ********** POTENTIAL BUG HERE *******
                      (fig-forth-auto680):01334         * ******** Should use labels in case opcodes change! ********
                      (fig-forth-auto680):01335         *       found NUL following the word instead of SPACE
                      (fig-forth-auto680):01336         * ENC0TR        LDB N
                      (fig-forth-auto680):01337         *       PSHS B  ; save EW
                      (fig-forth-auto680):01338         *       PSHS A  ; 
                      (fig-forth-auto680):01339         * ENCL8 LDB N   save NC
                      (fig-forth-auto680):01340         *       JMP     PUSHBA
                      (fig-forth-auto680):01341         
                      (fig-forth-auto680):01342                 PAGE
                      (fig-forth-auto680):01343         *
                      (fig-forth-auto680):01344         * ######>> screen 21 <<
                      (fig-forth-auto680):01345         * The next 4 words call system dependant I/O routines
                      (fig-forth-auto680):01346         * which are listed after word "-->" ( lable: "arrow" )
                      (fig-forth-auto680):01347         * in the dictionary.
                      (fig-forth-auto680):01348         *
                      (fig-forth-auto680):01349         * ======>>  13  <<
                      (fig-forth-auto680):01350         * ( c --- )
                      (fig-forth-auto680):01351         * Write c to the output device (screen or printer).
                      (fig-forth-auto680):01352         * ROM Uses the ECB device number at address $6F,
                      (fig-forth-auto680):01353         * -2 is printer, 0 is screen.
153B 84               (fig-forth-auto680):01354                 FCB     $84
153C 454D49           (fig-forth-auto680):01355                 FCC     'EMI'   ; 'EMIT'
153F D4               (fig-forth-auto680):01356                 FCB     $D4
1540 14F3             (fig-forth-auto680):01357                 FDB     ENCLOS-10
1542 1544             (fig-forth-auto680):01358         EMIT    FDB     *+NATWID
1544 3706             (fig-forth-auto680):01359                 PULU    D
1546 171067           (fig-forth-auto680):01360                 LBSR    PEMIT   ; PEMIT expects the character in D.
1549 0C33             (fig-forth-auto680):01361                 INC     <XOUT+1
154B 2602             (fig-forth-auto680):01362                 BNE     EMITDN
154D 0C32             (fig-forth-auto680):01363                 INC     <XOUT
154F 39               (fig-forth-auto680):01364         EMITDN  RTS
                      (fig-forth-auto680):01365         *       PULS A  ; 
                      (fig-forth-auto680):01366         *       PULS A  ; 
                      (fig-forth-auto680):01367         *       JSR     PEMIT
                      (fig-forth-auto680):01368         *       LDX     UP
                      (fig-forth-auto680):01369         *       INC XOUT+1-UORIG,X
                      (fig-forth-auto680):01370         *       BNE *+4 ; 
                      (fig-forth-auto680):01371         *       ****WARNING**** HARD OFFSET: *+4 ****
                      (fig-forth-auto680):01372         *       INC XOUT-UORIG,X
                      (fig-forth-auto680):01373         *       JMP     NEXT
                      (fig-forth-auto680):01374         *
                      (fig-forth-auto680):01375         * ======>>  14  <<
                      (fig-forth-auto680):01376         * ( --- c )
                      (fig-forth-auto680):01377         * ( --- BREAK )
                      (fig-forth-auto680):01378         * Wait for a key from the keyboard. 
                      (fig-forth-auto680):01379         * If the key is BREAK, set the high byte (result $FF03).
1550 83               (fig-forth-auto680):01380                 FCB     $83
1551 4B45             (fig-forth-auto680):01381                 FCC     'KE'    ; 'KEY'
1553 D9               (fig-forth-auto680):01382                 FCB     $D9
1554 153B             (fig-forth-auto680):01383                 FDB     EMIT-7
1556 1558             (fig-forth-auto680):01384         KEY     FDB     *+NATWID
1558 171062           (fig-forth-auto680):01385                 LBSR    PKEY    ; PKEY leaves the key/break code in D.
155B 3606             (fig-forth-auto680):01386                 PSHU    D
155D 39               (fig-forth-auto680):01387                 RTS
                      (fig-forth-auto680):01388         *       JSR     PKEY
                      (fig-forth-auto680):01389         *       PSHS A  ; 
                      (fig-forth-auto680):01390         *       CLRA    ;
                      (fig-forth-auto680):01391         *       PSHS A  ; 
                      (fig-forth-auto680):01392         *       JMP     NEXT
                      (fig-forth-auto680):01393         *
                      (fig-forth-auto680):01394         * ======>>  15  <<
                      (fig-forth-auto680):01395         * ( --- f )
                      (fig-forth-auto680):01396         * Scan keyboard, but do not wait.  
                      (fig-forth-auto680):01397         * Return 0 if no key,
                      (fig-forth-auto680):01398         * BREAK ($ff03) if BREAK is pressed,
                      (fig-forth-auto680):01399         * or key currently pressed.     
155E 89               (fig-forth-auto680):01400                 FCB     $89
155F 3F5445524D494E41 (fig-forth-auto680):01401                 FCC     '?TERMINA'      ; '?TERMINAL'
1567 CC               (fig-forth-auto680):01402                 FCB     $CC
1568 1550             (fig-forth-auto680):01403                 FDB     KEY-6
156A 156C             (fig-forth-auto680):01404         QTERM   FDB     *+NATWID
156C 171073           (fig-forth-auto680):01405                 LBSR    PQTER   ; PQTER leaves the flag/key in D.
156F 3606             (fig-forth-auto680):01406                 PSHU    D
1571 39               (fig-forth-auto680):01407                 RTS
                      (fig-forth-auto680):01408         *       JSR     PQTER
                      (fig-forth-auto680):01409         *       CLRB    ;
                      (fig-forth-auto680):01410         *       JMP     PUSHBA  stack the flag
                      (fig-forth-auto680):01411         *
                      (fig-forth-auto680):01412         * ======>>  16  <<
                      (fig-forth-auto680):01413         * ( --- )
                      (fig-forth-auto680):01414         * EMIT a Carriage Return (ASCII CR).
1572 82               (fig-forth-auto680):01415                 FCB     $82
1573 43               (fig-forth-auto680):01416                 FCC     'C'     ; 'CR'
1574 D2               (fig-forth-auto680):01417                 FCB     $D2
1575 155E             (fig-forth-auto680):01418                 FDB     QTERM-12
1577 1579             (fig-forth-auto680):01419         CR      FDB     *+NATWID
1579 161071           (fig-forth-auto680):01420                 LBRA    PCR     ; Nothing really to do here.
                      (fig-forth-auto680):01421         *       JSR     PCR
                      (fig-forth-auto680):01422         *       JMP     NEXT
                      (fig-forth-auto680):01423         *
                      (fig-forth-auto680):01424         * ######>> screen 22 <<
                      (fig-forth-auto680):01425         * ======>>  17  <<
                      (fig-forth-auto680):01426         * ( source target count --- )
                      (fig-forth-auto680):01427         * Copy/move count bytes from source to target.  
                      (fig-forth-auto680):01428         * Moves ascending addresses,
                      (fig-forth-auto680):01429         * so that overlapping only works if the source is above the destination.
157C 85               (fig-forth-auto680):01430                 FCB     $85
157D 434D4F56         (fig-forth-auto680):01431                 FCC     'CMOV'  ; 'CMOVE' :     source, destination, count
1581 C5               (fig-forth-auto680):01432                 FCB     $C5
1582 1572             (fig-forth-auto680):01433                 FDB     CR-5
1584 1586             (fig-forth-auto680):01434         CMOVE   FDB     *+NATWID
1586 3420             (fig-forth-auto680):01435                 PSHS    Y       ;
                      (fig-forth-auto680):01436         *       INC     <TRACEM
                      (fig-forth-auto680):01437         *       LBSR    DBGREG
1588 AE42             (fig-forth-auto680):01438                 LDX     1*NATWID,U
158A 10AE44           (fig-forth-auto680):01439                 LDY     2*NATWID,U
158D 2004             (fig-forth-auto680):01440                 BRA     CMOVLE  ;
158F                  (fig-forth-auto680):01441         CMOVLP
                      (fig-forth-auto680):01442         *       LBSR    DBGREG
158F A6A0             (fig-forth-auto680):01443                 LDA     ,Y+
1591 A780             (fig-forth-auto680):01444                 STA     ,X+
                      (fig-forth-auto680):01445         *       LBSR    DBGREG
1593                  (fig-forth-auto680):01446         CMOVLE
1593 ECC4             (fig-forth-auto680):01447                 LDD     ,U
1595 830001           (fig-forth-auto680):01448                 SUBD    #1
1598 EDC4             (fig-forth-auto680):01449                 STD     ,U
159A 24F3             (fig-forth-auto680):01450                 BCC     CMOVLP
159C 3346             (fig-forth-auto680):01451                 LEAU    3*NATWID,U
                      (fig-forth-auto680):01452         *       DEC     <TRACEM
159E 35A0             (fig-forth-auto680):01453                 PULS    Y,PC
                      (fig-forth-auto680):01454         * One way:              ; takes ( 37+17*count+9*(count/256) cycles )
                      (fig-forth-auto680):01455         *       PSHS    Y       ; #2~7 ; Gotta have our pointers.
                      (fig-forth-auto680):01456         *       INC     <TRACEM
                      (fig-forth-auto680):01457         *       LBSR    DBGREG
                      (fig-forth-auto680):01458         *       PULU    D,X,Y   ; #2~11
                      (fig-forth-auto680):01459         *       PSHS    A       ; #2~6 ; Gotta have our pointers.
                      (fig-forth-auto680):01460         *       BRA     CMOVLE  ; #2~3
                      (fig-forth-auto680):01461         * CMOVLP
                      (fig-forth-auto680):01462         *       LBSR    DBGREG
                      (fig-forth-auto680):01463         *       LDA     ,Y+     ; #2~6
                      (fig-forth-auto680):01464         *       STA     ,X+     ; #2~6
                      (fig-forth-auto680):01465         *       LBSR    DBGREG
                      (fig-forth-auto680):01466         * CMOVLE
                      (fig-forth-auto680):01467         *       SUBB    #1      ; #2~2
                      (fig-forth-auto680):01468         *       BCC     CMOVLP  ; #2~3
                      (fig-forth-auto680):01469         *       DEC     ,S      ; #2=6
                      (fig-forth-auto680):01470         *       BPL     CMOVLP  ; #2~3
                      (fig-forth-auto680):01471         *       DEC     <TRACEM
                      (fig-forth-auto680):01472         *       PULS    A,Y,PC  ; #2~10
                      (fig-forth-auto680):01473         * Another way           ; takes ( 42+17*count+9*(count/256) cycles )
                      (fig-forth-auto680):01474         *       LDD #0          ; #3~3
                      (fig-forth-auto680):01475         *       SUBD ,U++       ; #2~9 ; invert the count
                      (fig-forth-auto680):01476         *       PSHS A,Y        ; #2~8
                      (fig-forth-auto680):01477         *       PULU X,Y        ; #2~9
                      (fig-forth-auto680):01478         *       BEQ CMOVEX      ; #2~3
                      (fig-forth-auto680):01479         * CMOVEL
                      (fig-forth-auto680):01480         *       LDA ,Y+         ; #2~6
                      (fig-forth-auto680):01481         *       STA ,X+         ; #2~6
                      (fig-forth-auto680):01482         *       INCB            ; #1~2
                      (fig-forth-auto680):01483         *       BNE CMOVEL      ; #2~3
                      (fig-forth-auto680):01484         *       INC ,S          ; #2~6
                      (fig-forth-auto680):01485         *       BNE CMOVEL      ; #2~3
                      (fig-forth-auto680):01486         * CMOVEX
                      (fig-forth-auto680):01487         *       PULS A,Y,PC     ; #2~10
                      (fig-forth-auto680):01488         * Yet another way               ; takes ( 37+29*count cycles )
                      (fig-forth-auto680):01489         *       PSHS    Y       ; #2~7
                      (fig-forth-auto680):01490         *       LDX     NATWID,U        ; #2~6
                      (fig-forth-auto680):01491         *       LDY     NATWID,U        ; #3~7
                      (fig-forth-auto680):01492         *       BRA     CMOVLE  ; #2~3
                      (fig-forth-auto680):01493         * CMOVLP
                      (fig-forth-auto680):01494         *       LDA     ,Y+     ; #2~6
                      (fig-forth-auto680):01495         *       STA     ,X+     ; #2~6
                      (fig-forth-auto680):01496         * CMOVLE
                      (fig-forth-auto680):01497         *       LDD     ,U      ; #2~5
                      (fig-forth-auto680):01498         *       SUBD    #1      ; #3~4
                      (fig-forth-auto680):01499         *       STD     ,U      ; #2~5
                      (fig-forth-auto680):01500         *       BPL     CMOVLP  ; #2~3
                      (fig-forth-auto680):01501         *       LEAU    3*NATWID,U      ; #2~5
                      (fig-forth-auto680):01502         *       PULS    Y,PC    ; #2~9
                      (fig-forth-auto680):01503         * Yet another way               ; takes ( 44+24*odd+33*count/2 cycles )
                      (fig-forth-auto680):01504         *       PSHS    Y       ; #2~7
                      (fig-forth-auto680):01505         *       LDX     NATWID,U        ; #2~6
                      (fig-forth-auto680):01506         *       LDY     2*NATWID,U      ; #3~7
                      (fig-forth-auto680):01507         *       LDD     ,U      ; #2~5
                      (fig-forth-auto680):01508         *       BITB    #1      ; #2~2
                      (fig-forth-auto680):01509         *       BEQ     CMOVLE  ; #2~3
                      (fig-forth-auto680):01510         *       SUBD    #1      ; #3~4
                      (fig-forth-auto680):01511         *       STD     ,U      ; #2~5
                      (fig-forth-auto680):01512         *       LDA     ,Y+     ; #2~6
                      (fig-forth-auto680):01513         *       STA     ,X+     ; #2~6
                      (fig-forth-auto680):01514         *       BRA     CMOVLE  ; #2~3
                      (fig-forth-auto680):01515         * CMOVLP
                      (fig-forth-auto680):01516         *       LDD     ,Y++    ; #2~8
                      (fig-forth-auto680):01517         *       STD     ,X++    ; #2~8
                      (fig-forth-auto680):01518         * CMOVLI
                      (fig-forth-auto680):01519         *       LDD     ,U      ; #2~5
                      (fig-forth-auto680):01520         * CMOVLE
                      (fig-forth-auto680):01521         *       SUBD    #2      ; #3~4
                      (fig-forth-auto680):01522         *       STD     ,U      ; #2~5
                      (fig-forth-auto680):01523         *       BPL     CMOVLP  ; #2~3
                      (fig-forth-auto680):01524         *       LEAU    3*NATWID,U      ; #2~5
                      (fig-forth-auto680):01525         *       PULS    Y,PC    ; #2~9
                      (fig-forth-auto680):01526         * From the 6800 model:  
                      (fig-forth-auto680):01527         * CMOVE FDB     *+2     takes ( 43+47*count cycles ) on 6800
                      (fig-forth-auto680):01528         *       LDX     #N
                      (fig-forth-auto680):01529         *       LDB #6
                      (fig-forth-auto680):01530         * CMOV1 PULS A  ; 
                      (fig-forth-auto680):01531         *       STA 0,X move parameters to scratch area
                      (fig-forth-auto680):01532         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01533         *       DECB    ;
                      (fig-forth-auto680):01534         *       BNE     CMOV1
                      (fig-forth-auto680):01535         * CMOV2 LDA N
                      (fig-forth-auto680):01536         *       LDB N+1
                      (fig-forth-auto680):01537         *       SUBB #1
                      (fig-forth-auto680):01538         *       SBCA #0
                      (fig-forth-auto680):01539         *       STA N
                      (fig-forth-auto680):01540         *       STB N+1
                      (fig-forth-auto680):01541         *       BCS     CMOV3
                      (fig-forth-auto680):01542         *       LDX     N+4
                      (fig-forth-auto680):01543         *       LDA 0,X
                      (fig-forth-auto680):01544         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01545         *       STX     N+4
                      (fig-forth-auto680):01546         *       LDX     N+2
                      (fig-forth-auto680):01547         *       STA 0,X
                      (fig-forth-auto680):01548         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01549         *       STX     N+2
                      (fig-forth-auto680):01550         *       BRA     CMOV2
                      (fig-forth-auto680):01551         * CMOV3 JMP     NEXT
                      (fig-forth-auto680):01552         *
                      (fig-forth-auto680):01553         * ######>> screen 23 <<
                      (fig-forth-auto680):01554         * ======>>  18  <<
                      (fig-forth-auto680):01555         * ( u1 u2 --- ud )
                      (fig-forth-auto680):01556         * Multiplies the top two unsigned integers,
                      (fig-forth-auto680):01557         * yielding a double integer product.
15A0 82               (fig-forth-auto680):01558                 FCB     $82
15A1 55               (fig-forth-auto680):01559                 FCC     'U'     ; 'U*'
15A2 AA               (fig-forth-auto680):01560                 FCB     $AA
15A3 157C             (fig-forth-auto680):01561                 FDB     CMOVE-8
15A5 15A7             (fig-forth-auto680):01562         USTAR   FDB     *+NATWID
15A7 335C             (fig-forth-auto680):01563                 LEAU    -2*NATWID,U
15A9 A645             (fig-forth-auto680):01564                 LDA     2*NATWID+1,U    ; least
15AB E647             (fig-forth-auto680):01565                 LDB     3*NATWID+1,U
15AD 3D               (fig-forth-auto680):01566                 MUL
15AE ED42             (fig-forth-auto680):01567                 STD     NATWID,U
15B0 A644             (fig-forth-auto680):01568                 LDA     2*NATWID,U      ; most
15B2 E646             (fig-forth-auto680):01569                 LDB     3*NATWID,U
15B4 3D               (fig-forth-auto680):01570                 MUL
15B5 EDC4             (fig-forth-auto680):01571                 STD     ,U
15B7 EC45             (fig-forth-auto680):01572                 LDD     2*NATWID+1,U    ; first inner (u2 lo, u1 hi)
15B9 3D               (fig-forth-auto680):01573                 MUL
15BA E341             (fig-forth-auto680):01574                 ADDD    1,U
15BC 2402             (fig-forth-auto680):01575                 BCC     USTAR3
15BE 6CC4             (fig-forth-auto680):01576                 INC     ,U
15C0 ED41             (fig-forth-auto680):01577         USTAR3  STD     1,U
15C2 A644             (fig-forth-auto680):01578                 LDA     2*NATWID,U      ; second inner (u2 hi)
15C4 E646             (fig-forth-auto680):01579                 LDB     3*NATWID,U      ; (u1 lo)
15C6 3D               (fig-forth-auto680):01580                 MUL
15C7 E341             (fig-forth-auto680):01581                 ADDD    1,U
15C9 2402             (fig-forth-auto680):01582                 BCC     USTAR4
15CB 6CC4             (fig-forth-auto680):01583                 INC     ,U
15CD ED41             (fig-forth-auto680):01584         USTAR4  STD     1,U
15CF 3716             (fig-forth-auto680):01585                 PULU    D,X
15D1 EDC4             (fig-forth-auto680):01586                 STD     ,U
15D3 AF42             (fig-forth-auto680):01587                 STX     NATWID,U
15D5 39               (fig-forth-auto680):01588                 RTS
                      (fig-forth-auto680):01589         *
                      (fig-forth-auto680):01590         * from 6800 model:
                      (fig-forth-auto680):01591         *       BSR     USTARS
                      (fig-forth-auto680):01592         *       LEAS 1,S        ; 
                      (fig-forth-auto680):01593         *       LEAS 1,S        ; 
                      (fig-forth-auto680):01594         *       JMP     PUSHBA
                      (fig-forth-auto680):01595         *
                      (fig-forth-auto680):01596         * The following is a subroutine which 
                      (fig-forth-auto680):01597         * multiplies top 2 words on stack,
                      (fig-forth-auto680):01598         * leaving 32-bit result:  high order word in A,B
                      (fig-forth-auto680):01599         * low order word in 2nd word of stack.
                      (fig-forth-auto680):01600         *
                      (fig-forth-auto680):01601         * USTARS        LDA #16 bits/word counter
                      (fig-forth-auto680):01602         *       PSHS A  ; 
                      (fig-forth-auto680):01603         *       CLRA    ;
                      (fig-forth-auto680):01604         *       CLRB    ;
                      (fig-forth-auto680):01605         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):01606         * USTAR2        ROR 5,X shift multiplier
                      (fig-forth-auto680):01607         *       ROR 6,X
                      (fig-forth-auto680):01608         *       DEC 0,X done?
                      (fig-forth-auto680):01609         *       BMI     USTAR4
                      (fig-forth-auto680):01610         *       BCC     USTAR3
                      (fig-forth-auto680):01611         *       ADDB 4,X
                      (fig-forth-auto680):01612         *       ADCA 3,X
                      (fig-forth-auto680):01613         * USTAR3        RORA    ;
                      (fig-forth-auto680):01614         *       RORB    ;               shift result
                      (fig-forth-auto680):01615         *       BRA     USTAR2
                      (fig-forth-auto680):01616         * USTAR4        LEAS 1,S        ;               dump counter
                      (fig-forth-auto680):01617         *       RTS
                      (fig-forth-auto680):01618         *
                      (fig-forth-auto680):01619         * ######>> screen 24 <<
                      (fig-forth-auto680):01620         * ======>>  19  <<
                      (fig-forth-auto680):01621         * ( ud u --- uremainder uquotient )
                      (fig-forth-auto680):01622         * Divides the top unsigned integer
                      (fig-forth-auto680):01623         * into the second and third words on the stack
                      (fig-forth-auto680):01624         * as a single unsigned double integer,
                      (fig-forth-auto680):01625         * leaving the remainder and quotient (quotient on top)
                      (fig-forth-auto680):01626         * as unsigned integers.
                      (fig-forth-auto680):01627         *               
                      (fig-forth-auto680):01628         *    The smaller the divisor, the more likely dropping the high word 
                      (fig-forth-auto680):01629         *    of the quotient loses significant bits. See M/MOD .
                      (fig-forth-auto680):01630         *
15D6 82               (fig-forth-auto680):01631                 FCB     $82
15D7 55               (fig-forth-auto680):01632                 FCC     'U'     ; 'U/'
15D8 AF               (fig-forth-auto680):01633                 FCB     $AF
15D9 15A0             (fig-forth-auto680):01634                 FDB     USTAR-5
15DB 15DD             (fig-forth-auto680):01635         USLASH  FDB     *+NATWID
15DD 8611             (fig-forth-auto680):01636                 LDA     #17     ; bit ct
15DF 3402             (fig-forth-auto680):01637                 PSHS    A
15E1 EC42             (fig-forth-auto680):01638                 LDD     NATWID,U        ; dividend
15E3 10A3C4           (fig-forth-auto680):01639         USLDIV  CMPD    ,U      ; divisor
15E6 2404             (fig-forth-auto680):01640                 BHS     USLSUB
15E8 1CFE             (fig-forth-auto680):01641                 ANDCC   #~1     ; carry clear
15EA 2004             (fig-forth-auto680):01642                 BRA     USLBIT
15EC A3C4             (fig-forth-auto680):01643         USLSUB  SUBD    ,U
15EE 1A01             (fig-forth-auto680):01644                 ORCC    #1      ; quotient, (carry set)
15F0 6945             (fig-forth-auto680):01645         USLBIT  ROL     2*NATWID+1,U    ; save it
15F2 6944             (fig-forth-auto680):01646                 ROL     2*NATWID,U
15F4 6AE4             (fig-forth-auto680):01647                 DEC     ,S      ; more bits?
15F6 2706             (fig-forth-auto680):01648                 BEQ     USLR
15F8 59               (fig-forth-auto680):01649                 ROLB            ; remainder
15F9 49               (fig-forth-auto680):01650                 ROLA
15FA 24E7             (fig-forth-auto680):01651                 BCC     USLDIV
15FC 20EE             (fig-forth-auto680):01652                 BRA     USLSUB
15FE 3342             (fig-forth-auto680):01653         USLR    LEAU    NATWID,U
1600 AE42             (fig-forth-auto680):01654                 LDX     NATWID,U
1602 ED42             (fig-forth-auto680):01655                 STD     NATWID,U
1604 AFC4             (fig-forth-auto680):01656                 STX     ,U
1606 3582             (fig-forth-auto680):01657                 PULS    A,PC    ; Avoiding a LEAS 1,S by discarding A.
                      (fig-forth-auto680):01658         *
                      (fig-forth-auto680):01659         * from 6800 model:
                      (fig-forth-auto680):01660         *       LDA #17
                      (fig-forth-auto680):01661         *       PSHS A  ; 
                      (fig-forth-auto680):01662         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):01663         *       LDA 3,X
                      (fig-forth-auto680):01664         *       LDB 4,X
                      (fig-forth-auto680):01665         * USL1  CMPA 1,X
                      (fig-forth-auto680):01666         *       BHI     USL3
                      (fig-forth-auto680):01667         *       BCS     USL2
                      (fig-forth-auto680):01668         *       CMPB 2,X
                      (fig-forth-auto680):01669         *       BCC     USL3
                      (fig-forth-auto680):01670         * USL2  ANDCC #~$01     ; CLC : 
                      (fig-forth-auto680):01671         *       BRA     USL4
                      (fig-forth-auto680):01672         * USL3  SUBB 2,X
                      (fig-forth-auto680):01673         *       SBCA 1,X
                      (fig-forth-auto680):01674         *       ORCC #$01       ; SEC : 
                      (fig-forth-auto680):01675         * USL4  ROL 6,X
                      (fig-forth-auto680):01676         *       ROL 5,X
                      (fig-forth-auto680):01677         *       DEC 0,X
                      (fig-forth-auto680):01678         *       BEQ     USL5
                      (fig-forth-auto680):01679         *       ROLB    ;
                      (fig-forth-auto680):01680         *       ROLA    ;
                      (fig-forth-auto680):01681         *       BCC     USL1
                      (fig-forth-auto680):01682         *       BRA     USL3
                      (fig-forth-auto680):01683         * USL5  LEAS 1,S        ; 
                      (fig-forth-auto680):01684         *       LEAS 1,S        ; 
                      (fig-forth-auto680):01685         *       LEAS 1,S        ; 
                      (fig-forth-auto680):01686         *       LEAS 1,S        ; 
                      (fig-forth-auto680):01687         *       LEAS 1,S        ; 
                      (fig-forth-auto680):01688         *       JMP     SWAP+4  reverse quotient & remainder
                      (fig-forth-auto680):01689         *
                      (fig-forth-auto680):01690         * ######>> screen 25 <<
                      (fig-forth-auto680):01691         * ======>>  20  <<
                      (fig-forth-auto680):01692         * ( n1 n2 --- n )
                      (fig-forth-auto680):01693         * Bitwise and the top two integers.
1608 83               (fig-forth-auto680):01694                 FCB     $83
1609 414E             (fig-forth-auto680):01695                 FCC     'AN'    ; 'AND'
160B C4               (fig-forth-auto680):01696                 FCB     $C4
160C 15D6             (fig-forth-auto680):01697                 FDB     USLASH-5
160E 1610             (fig-forth-auto680):01698         AND     FDB     *+NATWID
1610 3706             (fig-forth-auto680):01699                 PULU    A,B
1612 E441             (fig-forth-auto680):01700                 ANDB    1,U
1614 A4C4             (fig-forth-auto680):01701                 ANDA    ,U
1616 EDC4             (fig-forth-auto680):01702                 STD     ,U
1618 39               (fig-forth-auto680):01703                 RTS
                      (fig-forth-auto680):01704         *       PULS A  ; 
                      (fig-forth-auto680):01705         *       PULS B  ; 
                      (fig-forth-auto680):01706         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):01707         *       ANDB 1,X
                      (fig-forth-auto680):01708         *       ANDA 0,X
                      (fig-forth-auto680):01709         *       JMP     STABX
                      (fig-forth-auto680):01710         *
                      (fig-forth-auto680):01711         * ======>>  21  <<
                      (fig-forth-auto680):01712         * ( n1 n2 --- n )
                      (fig-forth-auto680):01713         * Bitwise or the top two integers.
1619 82               (fig-forth-auto680):01714                 FCB     $82
161A 4F               (fig-forth-auto680):01715                 FCC     'O'     ; 'OR'
161B D2               (fig-forth-auto680):01716                 FCB     $D2
161C 1608             (fig-forth-auto680):01717                 FDB     AND-6
161E 1620             (fig-forth-auto680):01718         OR      FDB     *+NATWID
1620 3706             (fig-forth-auto680):01719                 PULU    A,B
1622 EA41             (fig-forth-auto680):01720                 ORB     1,U
1624 AAC4             (fig-forth-auto680):01721                 ORA     ,U
1626 EDC4             (fig-forth-auto680):01722                 STD     ,U
1628 39               (fig-forth-auto680):01723                 RTS
                      (fig-forth-auto680):01724         *       PULS A  ; 
                      (fig-forth-auto680):01725         *       PULS B  ; 
                      (fig-forth-auto680):01726         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):01727         *       ORB 1,X
                      (fig-forth-auto680):01728         *       ORA 0,X
                      (fig-forth-auto680):01729         *       JMP     STABX
                      (fig-forth-auto680):01730         *       
                      (fig-forth-auto680):01731         * ======>>  22  <<
                      (fig-forth-auto680):01732         * ( n1 n2 --- n )
                      (fig-forth-auto680):01733         * Bitwise exclusive or the top two integers.
1629 83               (fig-forth-auto680):01734                 FCB     $83
162A 584F             (fig-forth-auto680):01735                 FCC     'XO'    ; 'XOR'
162C D2               (fig-forth-auto680):01736                 FCB     $D2
162D 1619             (fig-forth-auto680):01737                 FDB     OR-5
162F 1631             (fig-forth-auto680):01738         XOR     FDB     *+NATWID
1631 3706             (fig-forth-auto680):01739                 PULU    A,B
1633 E841             (fig-forth-auto680):01740                 EORB    1,U
1635 A8C4             (fig-forth-auto680):01741                 EORA    ,U
1637 EDC4             (fig-forth-auto680):01742                 STD     ,U
1639 39               (fig-forth-auto680):01743                 RTS
                      (fig-forth-auto680):01744         *       PULS A  ; 
                      (fig-forth-auto680):01745         *       PULS B  ; 
                      (fig-forth-auto680):01746         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):01747         *       EORB 1,X
                      (fig-forth-auto680):01748         *       EORA 0,X
                      (fig-forth-auto680):01749         *       JMP     STABX
                      (fig-forth-auto680):01750         *
                      (fig-forth-auto680):01751         * ######>> screen 26 <<
                      (fig-forth-auto680):01752         * ======>>  23  <<
                      (fig-forth-auto680):01753         * ( --- adr )
                      (fig-forth-auto680):01754         * Fetch the parameter stack pointer (before it is pushed).
                      (fig-forth-auto680):01755         * This points at whatever was on the top of stack before.
163A 83               (fig-forth-auto680):01756                 FCB     $83
163B 5350             (fig-forth-auto680):01757                 FCC     'SP'    ; 'SP@'
163D C0               (fig-forth-auto680):01758                 FCB     $C0
163E 1629             (fig-forth-auto680):01759                 FDB     XOR-6
1640 1642             (fig-forth-auto680):01760         SPAT    FDB     *+NATWID
1642 1F31             (fig-forth-auto680):01761                 TFR     U,X
1644 3610             (fig-forth-auto680):01762                 PSHU    X
1646 39               (fig-forth-auto680):01763                 RTS
                      (fig-forth-auto680):01764         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):01765         *       STX     N       scratch area
                      (fig-forth-auto680):01766         *       LDX     #N
                      (fig-forth-auto680):01767         *       JMP     GETX
                      (fig-forth-auto680):01768         *
                      (fig-forth-auto680):01769         * ======>>  24  <<
                      (fig-forth-auto680):01770         * ( whatever --- nothing )
                      (fig-forth-auto680):01771         * Initialize the parameter stack pointer from the USER variable S0. 
                      (fig-forth-auto680):01772         * Effectively clears the stack.
1647 83               (fig-forth-auto680):01773                 FCB     $83
1648 5350             (fig-forth-auto680):01774                 FCC     'SP'    ; 'SP!'
164A A1               (fig-forth-auto680):01775                 FCB     $A1
164B 163A             (fig-forth-auto680):01776                 FDB     SPAT-6
164D 164F             (fig-forth-auto680):01777         SPSTOR  FDB     *+NATWID
164F DE1E             (fig-forth-auto680):01778                 LDU     <XSPZER
1651 39               (fig-forth-auto680):01779                 RTS
                      (fig-forth-auto680):01780         *       LDX     UP
                      (fig-forth-auto680):01781         *       LDX     XSPZER-UORIG,X
                      (fig-forth-auto680):01782         *       TFR X,S ; TXS :                 watch it ! X and S are not equal on 6800.
                      (fig-forth-auto680):01783         *       JMP     NEXT
                      (fig-forth-auto680):01784         * ======>>  25  <<
                      (fig-forth-auto680):01785         * ( whatever *** nothing )
                      (fig-forth-auto680):01786         * Initialize the return stack pointer from the initialization table
                      (fig-forth-auto680):01787         * instead of the user variable R0, for some reason.
                      (fig-forth-auto680):01788         * Quite possibly, this should be from R0.
                      (fig-forth-auto680):01789         * Effectively aborts all in process definitions, except the active one. 
                      (fig-forth-auto680):01790         * An emergency measure, to be sure.
                      (fig-forth-auto680):01791         * The routine that calls this must never execute a return.
                      (fig-forth-auto680):01792         * So this should never be executed from the terminal, I guess.
                      (fig-forth-auto680):01793         * This is another that should be compile-time only, and in a separate vocabulary.
1652 83               (fig-forth-auto680):01794                 FCB     $83
1653 5250             (fig-forth-auto680):01795                 FCC     'RP'    ; 'RP!'
1655 A1               (fig-forth-auto680):01796                 FCB     $A1
1656 1647             (fig-forth-auto680):01797                 FDB     SPSTOR-6
1658 165A             (fig-forth-auto680):01798         RPSTOR  FDB     *+NATWID
165A 3510             (fig-forth-auto680):01799                 PULS    X       ; But this guy has to return to his caller.
165C 10FE1214         (fig-forth-auto680):01800                 LDS     RINIT
1660 6E84             (fig-forth-auto680):01801                 JMP     ,X
                      (fig-forth-auto680):01802         *       LDX     RINIT   initialize from rom constant
                      (fig-forth-auto680):01803         *       STX     RP
                      (fig-forth-auto680):01804         *       JMP     NEXT
                      (fig-forth-auto680):01805         *
                      (fig-forth-auto680):01806         * ======>>  26  <<
                      (fig-forth-auto680):01807         * ( ip *** )
                      (fig-forth-auto680):01808         * Pop IP from return stack (return from high-level definition).
                      (fig-forth-auto680):01809         * Can be used in a screen to force interpretion to terminate.
                      (fig-forth-auto680):01810         * Must not be executed when temporaries are saved on top of the return stack.
1662 82               (fig-forth-auto680):01811                 FCB     $82
1663 3B               (fig-forth-auto680):01812                 FCC     ';'     ; ';S'
1664 D3               (fig-forth-auto680):01813                 FCB     $D3
1665 1652             (fig-forth-auto680):01814                 FDB     RPSTOR-6
1667 1669             (fig-forth-auto680):01815         SEMIS   FDB     *+NATWID
1669 3526             (fig-forth-auto680):01816                 PULS    D,Y     ; return address in D, and saved IP in Y.
166B 1F05             (fig-forth-auto680):01817                 TFR     D,PC    ; Synthetic return.
                      (fig-forth-auto680):01818         *
                      (fig-forth-auto680):01819         * Form 6800 model:
                      (fig-forth-auto680):01820         *       LDX     RP
                      (fig-forth-auto680):01821         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01822         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01823         *       STX     RP
                      (fig-forth-auto680):01824         *       LDX     0,X     get address we have just finished.
                      (fig-forth-auto680):01825         *       JMP     NEXT+2  increment the return address & do next word
                      (fig-forth-auto680):01826         *
                      (fig-forth-auto680):01827         * ######>> screen 27 <<
                      (fig-forth-auto680):01828         * ======>>  27  <<
                      (fig-forth-auto680):01829         * ( limit index *** index index )
                      (fig-forth-auto680):01830         * Force the terminating condition for the innermost loop by
                      (fig-forth-auto680):01831         * copying its index to its limit. 
                      (fig-forth-auto680):01832         * Termination is postponed until the next
                      (fig-forth-auto680):01833         * LOOP or +LOOP instruction is executed. 
                      (fig-forth-auto680):01834         * The index remains available for use until
                      (fig-forth-auto680):01835         * the LOOP or +LOOP instruction is encountered.
                      (fig-forth-auto680):01836         * Note that the assumption is that the current count is the correct count 
                      (fig-forth-auto680):01837         * to end at, rather than pushing the count to the final count.
166D 85               (fig-forth-auto680):01838                 FCB     $85
166E 4C454156         (fig-forth-auto680):01839                 FCC     'LEAV'  ; 'LEAVE'
1672 C5               (fig-forth-auto680):01840                 FCB     $C5
1673 1662             (fig-forth-auto680):01841                 FDB     SEMIS-5
1675 1677             (fig-forth-auto680):01842         LEAVE   FDB     *+NATWID
1677 EC62             (fig-forth-auto680):01843                 LDD     NATWID,S        ; Dodge the return address.
1679 ED64             (fig-forth-auto680):01844                 STD     2*NATWID,S
167B 39               (fig-forth-auto680):01845                 RTS
                      (fig-forth-auto680):01846         *       LDX     RP
                      (fig-forth-auto680):01847         *       LDA 2,X
                      (fig-forth-auto680):01848         *       LDB 3,X
                      (fig-forth-auto680):01849         *       STA 4,X
                      (fig-forth-auto680):01850         *       STB 5,X
                      (fig-forth-auto680):01851         *       JMP     NEXT
                      (fig-forth-auto680):01852         *
                      (fig-forth-auto680):01853         * ======>>  28  <<
                      (fig-forth-auto680):01854         * ( n --- )              
                      (fig-forth-auto680):01855         * ( *** n ) 
                      (fig-forth-auto680):01856         * Move top of parameter stack to top of return stack.
167C 82               (fig-forth-auto680):01857                 FCB     $82
167D 3E               (fig-forth-auto680):01858                 FCC     '>'     ; '>R'
167E D2               (fig-forth-auto680):01859                 FCB     $D2
167F 166D             (fig-forth-auto680):01860                 FDB     LEAVE-8
1681 1683             (fig-forth-auto680):01861         TOR     FDB     *+NATWID
1683 3706             (fig-forth-auto680):01862                 PULU    A,B
1685 AEE4             (fig-forth-auto680):01863                 LDX     ,S
1687 EDE4             (fig-forth-auto680):01864                 STD     ,S      ; Put it where the return address was.
1689 6E84             (fig-forth-auto680):01865                 JMP     ,X
                      (fig-forth-auto680):01866         *       LDX     RP
                      (fig-forth-auto680):01867         *       LEAX -1,X       ; 
                      (fig-forth-auto680):01868         *       LEAX -1,X       ; 
                      (fig-forth-auto680):01869         *       STX     RP
                      (fig-forth-auto680):01870         *       PULS A  ; 
                      (fig-forth-auto680):01871         *       PULS B  ; 
                      (fig-forth-auto680):01872         *       STA 2,X
                      (fig-forth-auto680):01873         *       STB 3,X
                      (fig-forth-auto680):01874         *       JMP     NEXT
                      (fig-forth-auto680):01875         *
                      (fig-forth-auto680):01876         * ======>>  29  <<
                      (fig-forth-auto680):01877         * ( --- n )              
                      (fig-forth-auto680):01878         * ( n *** )  
                      (fig-forth-auto680):01879         * Move top of return stack to top of parameter stack.
168B 82               (fig-forth-auto680):01880                 FCB     $82
168C 52               (fig-forth-auto680):01881                 FCC     'R'     ; 'R>'
168D BE               (fig-forth-auto680):01882                 FCB     $BE
168E 167C             (fig-forth-auto680):01883                 FDB     TOR-5
1690 1692             (fig-forth-auto680):01884         FROMR   FDB     *+NATWID
1692 3516             (fig-forth-auto680):01885                 PULS    D,X
1694 3610             (fig-forth-auto680):01886                 PSHU    X
1696 1F05             (fig-forth-auto680):01887                 TFR     D,PC
                      (fig-forth-auto680):01888         *       LDX     RP
                      (fig-forth-auto680):01889         *       LDA 2,X
                      (fig-forth-auto680):01890         *       LDB 3,X
                      (fig-forth-auto680):01891         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01892         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01893         *       STX     RP
                      (fig-forth-auto680):01894         *       JMP     PUSHBA
                      (fig-forth-auto680):01895         *
                      (fig-forth-auto680):01896         * ======>>  30  <<
                      (fig-forth-auto680):01897         * ( --- n )             
                      (fig-forth-auto680):01898         * ( n *** n )
                      (fig-forth-auto680):01899         * Copy the top of return stack to top of parameter stack. 
                      (fig-forth-auto680):01900         * A synonym for I.
1698 81               (fig-forth-auto680):01901                 FCB     $81     R
1699 D2               (fig-forth-auto680):01902                 FCB     $D2
169A 168B             (fig-forth-auto680):01903                 FDB     FROMR-5
169C 1467             (fig-forth-auto680):01904         R       FDB     I+NATWID
                      (fig-forth-auto680):01905         
                      (fig-forth-auto680):01906         *       LDX     RP
                      (fig-forth-auto680):01907         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01908         *       LEAX 1,X        ; 
                      (fig-forth-auto680):01909         *       JMP     GETX
                      (fig-forth-auto680):01910         *
                      (fig-forth-auto680):01911         * ######>> screen 28 <<
                      (fig-forth-auto680):01912         * ======>>  31  <<
                      (fig-forth-auto680):01913         * ( n --- n=0 )
                      (fig-forth-auto680):01914         * Logically invert top of stack;
                      (fig-forth-auto680):01915         * or flag true if top is zero, otherwise false.
169E 82               (fig-forth-auto680):01916                 FCB     $82
169F 30               (fig-forth-auto680):01917                 FCC     '0'     ; '0='
16A0 BD               (fig-forth-auto680):01918                 FCB     $BD
16A1 1698             (fig-forth-auto680):01919                 FDB     R-4
16A3 16A5             (fig-forth-auto680):01920         ZEQU    FDB     *+NATWID
16A5 CC0000           (fig-forth-auto680):01921                 LDD     #0
16A8 AEC4             (fig-forth-auto680):01922                 LDX     ,U
16AA 2601             (fig-forth-auto680):01923                 BNE     ZEQUF
16AC 5C               (fig-forth-auto680):01924                 INCB    ; 1 is true
16AD EDC4             (fig-forth-auto680):01925         ZEQUF   STD     ,U
16AF 39               (fig-forth-auto680):01926                 RTS
                      (fig-forth-auto680):01927         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):01928         *       CLRA    ;
                      (fig-forth-auto680):01929         *       CLRB    ;
                      (fig-forth-auto680):01930         *       LDX     0,X
                      (fig-forth-auto680):01931         *       BNE     ZEQU2
                      (fig-forth-auto680):01932         *       INCB    ;
                      (fig-forth-auto680):01933         *ZEQU2  TFR S,X ; TSX : 
                      (fig-forth-auto680):01934         *       JMP     STABX
                      (fig-forth-auto680):01935         *
                      (fig-forth-auto680):01936         * ======>>  32  <<
                      (fig-forth-auto680):01937         * ( n --- n<0 )
                      (fig-forth-auto680):01938         * Flag true if top is negative (MSbit set), otherwise false.
16B0 82               (fig-forth-auto680):01939                 FCB     $82
16B1 30               (fig-forth-auto680):01940                 FCC     '0'     ; '0<'
16B2 BC               (fig-forth-auto680):01941                 FCB     $BC
16B3 169E             (fig-forth-auto680):01942                 FDB     ZEQU-5
16B5 16B7             (fig-forth-auto680):01943         ZLESS   FDB     *+NATWID
16B7 CC0000           (fig-forth-auto680):01944                 LDD     #0
16BA 6DC4             (fig-forth-auto680):01945                 TST     ,U
16BC 2A01             (fig-forth-auto680):01946                 BPL     ZLESSF
16BE 5C               (fig-forth-auto680):01947                 INCB
16BF EDC4             (fig-forth-auto680):01948         ZLESSF  STD     ,U
16C1 39               (fig-forth-auto680):01949                 RTS
                      (fig-forth-auto680):01950         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):01951         *       LDA #$80        check the sign bit
                      (fig-forth-auto680):01952         *       ANDA 0,X
                      (fig-forth-auto680):01953         *       BEQ     ZLESS2
                      (fig-forth-auto680):01954         *       CLRA    ;               if neg.
                      (fig-forth-auto680):01955         *       LDB #1
                      (fig-forth-auto680):01956         *       JMP     STABX
                      (fig-forth-auto680):01957         * ZLESS2        CLRB    ;
                      (fig-forth-auto680):01958         *       JMP     STABX
                      (fig-forth-auto680):01959         *
                      (fig-forth-auto680):01960         * ######>> screen 29 <<
                      (fig-forth-auto680):01961         * ======>>  33  <<
                      (fig-forth-auto680):01962         * ( n1 n2 --- n1+n2 )
                      (fig-forth-auto680):01963         * Add top two words.
16C2 81               (fig-forth-auto680):01964                 FCB     $81     '+'
16C3 AB               (fig-forth-auto680):01965                 FCB     $AB
16C4 16B0             (fig-forth-auto680):01966                 FDB     ZLESS-5
16C6 16C8             (fig-forth-auto680):01967         PLUS    FDB     *+NATWID
16C8 3706             (fig-forth-auto680):01968                 PULU    A,B     ; #2~7
16CA E3C4             (fig-forth-auto680):01969                 ADDD    ,U      ; #2~6
16CC EDC4             (fig-forth-auto680):01970                 STD     ,U      ; #2~5
16CE 39               (fig-forth-auto680):01971                 RTS             ; #1~5  =#7~23
                      (fig-forth-auto680):01972         *       PULS A  ; 
                      (fig-forth-auto680):01973         *       PULS B  ; 
                      (fig-forth-auto680):01974         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):01975         *       ADDB 1,X
                      (fig-forth-auto680):01976         *       ADCA 0,X
                      (fig-forth-auto680):01977         *       JMP     STABX
                      (fig-forth-auto680):01978         *
                      (fig-forth-auto680):01979         * ======>>  34  <<
                      (fig-forth-auto680):01980         * ( d1 d2 --- d1+d2 )
                      (fig-forth-auto680):01981         * Add top two double integers.
16CF 82               (fig-forth-auto680):01982                 FCB     $82
16D0 44               (fig-forth-auto680):01983                 FCC     'D'     ; 'D+'
16D1 AB               (fig-forth-auto680):01984                 FCB     $AB
16D2 16C2             (fig-forth-auto680):01985                 FDB     PLUS-4
16D4 16D6             (fig-forth-auto680):01986         DPLUS   FDB     *+NATWID
16D6 EC46             (fig-forth-auto680):01987                 LDD     3*NATWID,U
16D8 E342             (fig-forth-auto680):01988                 ADDD    NATWID,U
16DA ED46             (fig-forth-auto680):01989                 STD     3*NATWID,U
16DC EC44             (fig-forth-auto680):01990                 LDD     2*NATWID,U
16DE E941             (fig-forth-auto680):01991                 ADCB    1,U
16E0 A9C4             (fig-forth-auto680):01992                 ADCA    ,U
16E2 3344             (fig-forth-auto680):01993                 LEAU    2*NATWID,U
16E4 EDC4             (fig-forth-auto680):01994                 STD     ,U
16E6 39               (fig-forth-auto680):01995                 RTS
                      (fig-forth-auto680):01996         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):01997         *       ANDCC #~$01     ; CLC : 
                      (fig-forth-auto680):01998         *       LDB #4
                      (fig-forth-auto680):01999         * DPLUS2        LDA 3,X
                      (fig-forth-auto680):02000         *       ADCA 7,X
                      (fig-forth-auto680):02001         *       STA 7,X
                      (fig-forth-auto680):02002         *       LEAX -1,X       ; 
                      (fig-forth-auto680):02003         *       DECB    ;
                      (fig-forth-auto680):02004         *       BNE     DPLUS2
                      (fig-forth-auto680):02005         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02006         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02007         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02008         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02009         *       JMP     NEXT
                      (fig-forth-auto680):02010         *
                      (fig-forth-auto680):02011         * ======>>  35  <<
                      (fig-forth-auto680):02012         * ( n --- -n )
                      (fig-forth-auto680):02013         * Negate (two's complement) top of stack.
16E7 85               (fig-forth-auto680):02014                 FCB     $85
16E8 4D494E55         (fig-forth-auto680):02015                 FCC     'MINU'  ; 'MINUS'
16EC D3               (fig-forth-auto680):02016                 FCB     $D3
16ED 16CF             (fig-forth-auto680):02017                 FDB     DPLUS-5
16EF 16F1             (fig-forth-auto680):02018         MINUS   FDB     *+NATWID
16F1 CC0000           (fig-forth-auto680):02019                 LDD     #0      ; #3~3
16F4 A3C4             (fig-forth-auto680):02020                 SUBD    ,U      ; #2~5
16F6 EDC4             (fig-forth-auto680):02021                 STD     ,U      ; #2~5
16F8 39               (fig-forth-auto680):02022                 RTS             ; #1~5  = #8~18
                      (fig-forth-auto680):02023         * 
                      (fig-forth-auto680):02024         * from 6800 model code:
                      (fig-forth-auto680):02025         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):02026         *       NEG 1,X
                      (fig-forth-auto680):02027         *       BCC     MINUS2
                      (fig-forth-auto680):02028         *       NEG 0,X
                      (fig-forth-auto680):02029         *       BRA     MINUS3
                      (fig-forth-auto680):02030         * MINUS2        COM 0,X
                      (fig-forth-auto680):02031         * MINUS3        JMP     NEXT
                      (fig-forth-auto680):02032         *
                      (fig-forth-auto680):02033         * ======>>  36  <<
                      (fig-forth-auto680):02034         * ( d --- -d )
                      (fig-forth-auto680):02035         * Negate (two's complement) top two words on stack as a double integer.
16F9 86               (fig-forth-auto680):02036                 FCB     $86
16FA 444D494E55       (fig-forth-auto680):02037                 FCC     'DMINU' ; 'DMINUS'
16FF D3               (fig-forth-auto680):02038                 FCB     $D3
1700 16E7             (fig-forth-auto680):02039                 FDB     MINUS-8
1702 1704             (fig-forth-auto680):02040         DMINUS  FDB     *+NATWID
1704 CC0000           (fig-forth-auto680):02041                 LDD     #0      ; #3~3
1707 A342             (fig-forth-auto680):02042                 SUBD    NATWID,U        ; #2~7
1709 ED42             (fig-forth-auto680):02043                 STD     NATWID,U        ; #2~7
170B CC0000           (fig-forth-auto680):02044                 LDD     #0      ; #3~3
170E E241             (fig-forth-auto680):02045                 SBCB    1,U     ; #2~5
1710 A2C4             (fig-forth-auto680):02046                 SBCA    ,U      ; #2~4
1712 EDC4             (fig-forth-auto680):02047                 STD     ,U      ; #2~5
1714 39               (fig-forth-auto680):02048                 RTS             ; #1~5  = #17~39
                      (fig-forth-auto680):02049         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):02050         *       COM 0,X
                      (fig-forth-auto680):02051         *       COM 1,X
                      (fig-forth-auto680):02052         *       COM 2,X
                      (fig-forth-auto680):02053         *       NEG 3,X
                      (fig-forth-auto680):02054         *       BNE     DMINX
                      (fig-forth-auto680):02055         *       INC 2,X
                      (fig-forth-auto680):02056         *       BNE     DMINX
                      (fig-forth-auto680):02057         *       INC 1,X
                      (fig-forth-auto680):02058         *       BNE     DMINX
                      (fig-forth-auto680):02059         *       INC 0,X
                      (fig-forth-auto680):02060         * DMINX JMP     NEXT
                      (fig-forth-auto680):02061         *
                      (fig-forth-auto680):02062         * ######>> screen 30 <<
                      (fig-forth-auto680):02063         * ======>>  37  <<
                      (fig-forth-auto680):02064         * ( n1 n2 --- n1 n2 n1 )
                      (fig-forth-auto680):02065         * Push a copy of the second word on stack.
1715 84               (fig-forth-auto680):02066                 FCB     $84
1716 4F5645           (fig-forth-auto680):02067                 FCC     'OVE'   ; 'OVER'
1719 D2               (fig-forth-auto680):02068                 FCB     $D2
171A 16F9             (fig-forth-auto680):02069                 FDB     DMINUS-9
171C 171E             (fig-forth-auto680):02070         OVER    FDB     *+NATWID
171E EC42             (fig-forth-auto680):02071                 LDD     NATWID,U
1720 3606             (fig-forth-auto680):02072                 PSHU    D
1722 39               (fig-forth-auto680):02073                 RTS
                      (fig-forth-auto680):02074         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):02075         *       LDA 2,X
                      (fig-forth-auto680):02076         *       LDB 3,X
                      (fig-forth-auto680):02077         *       JMP     PUSHBA
                      (fig-forth-auto680):02078         *
                      (fig-forth-auto680):02079         * ======>>  38  <<
                      (fig-forth-auto680):02080         * ( n --- )
                      (fig-forth-auto680):02081         * Discard the top word on stack.
1723 84               (fig-forth-auto680):02082                 FCB     $84
1724 44524F           (fig-forth-auto680):02083                 FCC     'DRO'   ; 'DROP'
1727 D0               (fig-forth-auto680):02084                 FCB     $D0
1728 1715             (fig-forth-auto680):02085                 FDB     OVER-7
172A 172C             (fig-forth-auto680):02086         DROP    FDB     *+NATWID
172C 3342             (fig-forth-auto680):02087                 LEAU    NATWID,U
172E 39               (fig-forth-auto680):02088                 RTS
                      (fig-forth-auto680):02089         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02090         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02091         *       JMP     NEXT
                      (fig-forth-auto680):02092         *
                      (fig-forth-auto680):02093         * ======>>  39  <<
                      (fig-forth-auto680):02094         * ( n1 n2 --- n2 n1 )
                      (fig-forth-auto680):02095         * Swap the top two words on stack.
172F 84               (fig-forth-auto680):02096                 FCB     $84
1730 535741           (fig-forth-auto680):02097                 FCC     'SWA'   ; 'SWAP'
1733 D0               (fig-forth-auto680):02098                 FCB     $D0
1734 1723             (fig-forth-auto680):02099                 FDB     DROP-7
1736 1738             (fig-forth-auto680):02100         SWAP    FDB     *+NATWID
1738 3716             (fig-forth-auto680):02101                 PULU    D,X
173A 3606             (fig-forth-auto680):02102                 PSHU    D
173C 3610             (fig-forth-auto680):02103                 PSHU    X
173E 39               (fig-forth-auto680):02104                 RTS
                      (fig-forth-auto680):02105         *       PULS A  ; 
                      (fig-forth-auto680):02106         *       PULS B  ; 
                      (fig-forth-auto680):02107         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):02108         *       LDX     0,X
                      (fig-forth-auto680):02109         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02110         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02111         *       PSHS B  ; 
                      (fig-forth-auto680):02112         *       PSHS A  ; 
                      (fig-forth-auto680):02113         *       STX     N
                      (fig-forth-auto680):02114         *       LDX     #N
                      (fig-forth-auto680):02115         *       JMP     GETX
                      (fig-forth-auto680):02116         *
                      (fig-forth-auto680):02117         * ======>>  40  <<
                      (fig-forth-auto680):02118         * ( n1 --- n1 n1 )
                      (fig-forth-auto680):02119         * Push a copy of the top word on stack.
173F 83               (fig-forth-auto680):02120                 FCB     $83
1740 4455             (fig-forth-auto680):02121                 FCC     'DU'    ; 'DUP'
1742 D0               (fig-forth-auto680):02122                 FCB     $D0
1743 172F             (fig-forth-auto680):02123                 FDB     SWAP-7
1745 1747             (fig-forth-auto680):02124         DUP     FDB     *+NATWID
1747 ECC4             (fig-forth-auto680):02125                 LDD     ,U
1749 3606             (fig-forth-auto680):02126                 PSHU    D
174B 39               (fig-forth-auto680):02127                 RTS
                      (fig-forth-auto680):02128         *       PULS A  ; 
                      (fig-forth-auto680):02129         *       PULS B  ; 
                      (fig-forth-auto680):02130         *       PSHS B  ; 
                      (fig-forth-auto680):02131         *       PSHS A  ; 
                      (fig-forth-auto680):02132         *       JMP PUSHBA
                      (fig-forth-auto680):02133         *
                      (fig-forth-auto680):02134         * ######>> screen 31 <<
                      (fig-forth-auto680):02135         * ======>>  41  <<
                      (fig-forth-auto680):02136         * ( n adr --- )
                      (fig-forth-auto680):02137         * Add the second word on stack to the word at the adr on top of stack.
174C 82               (fig-forth-auto680):02138                 FCB     $82
174D 2B               (fig-forth-auto680):02139                 FCC     '+'     ; '+!'
174E A1               (fig-forth-auto680):02140                 FCB     $A1
174F 173F             (fig-forth-auto680):02141                 FDB     DUP-6
1751 1753             (fig-forth-auto680):02142         PSTORE  FDB     *+NATWID
1753 3710             (fig-forth-auto680):02143                 PULU    X
1755 EC84             (fig-forth-auto680):02144                 LDD     ,X
1757 E3C1             (fig-forth-auto680):02145                 ADDD    ,U++
1759 ED84             (fig-forth-auto680):02146                 STD     ,X
175B 39               (fig-forth-auto680):02147                 RTS
                      (fig-forth-auto680):02148         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):02149         *       LDX     0,X
                      (fig-forth-auto680):02150         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02151         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02152         *       PULS A  ; get stack data
                      (fig-forth-auto680):02153         *       PULS B  ; 
                      (fig-forth-auto680):02154         *       ADDB 1,X        add & store low byte
                      (fig-forth-auto680):02155         *       STB 1,X
                      (fig-forth-auto680):02156         *       ADCA 0,X        add & store hi byte
                      (fig-forth-auto680):02157         *       STA 0,X
                      (fig-forth-auto680):02158         *       JMP     NEXT
                      (fig-forth-auto680):02159         *
                      (fig-forth-auto680):02160         * ======>>  42  <<
                      (fig-forth-auto680):02161         * ( adr b --- )
                      (fig-forth-auto680):02162         * Exclusive or byte at adr with low byte of top word.
175C 86               (fig-forth-auto680):02163                 FCB     $86
175D 544F47474C       (fig-forth-auto680):02164                 FCC     'TOGGL' ; 'TOGGLE'
1762 C5               (fig-forth-auto680):02165                 FCB     $C5
1763 174C             (fig-forth-auto680):02166                 FDB     PSTORE-5
1765 1767             (fig-forth-auto680):02167         TOGGLE  FDB     *+NATWID
1767 3716             (fig-forth-auto680):02168                 PULU    D,X
1769 E884             (fig-forth-auto680):02169                 EORB    ,X
176B E784             (fig-forth-auto680):02170                 STB     ,X
176D 39               (fig-forth-auto680):02171                 RTS
                      (fig-forth-auto680):02172         * Using the model code would be less likely to introduce bugs, 
                      (fig-forth-auto680):02173         * but that would sort-of defeat my purposes here.
                      (fig-forth-auto680):02174         * Anyway, I can borrow from theoretically known good bif-6809 code
                      (fig-forth-auto680):02175         * and it's fewer bytes and much faster code this way.
                      (fig-forth-auto680):02176         * TOGGLE
                      (fig-forth-auto680):02177         *       FDB     DOCOL,OVER,CAT,XOR,SWAP,CSTORE
                      (fig-forth-auto680):02178         *       FDB     SEMIS
                      (fig-forth-auto680):02179         *
                      (fig-forth-auto680):02180         * ######>> screen 32 <<
                      (fig-forth-auto680):02181         * ======>>  43  <<
                      (fig-forth-auto680):02182         * ( adr --- n )
                      (fig-forth-auto680):02183         * Replace address on stack with the word at the address.
176E 81               (fig-forth-auto680):02184                 FCB     $81     @
176F C0               (fig-forth-auto680):02185                 FCB     $C0
1770 175C             (fig-forth-auto680):02186                 FDB     TOGGLE-9
1772 1774             (fig-forth-auto680):02187         AT      FDB     *+NATWID
1774 ECD4             (fig-forth-auto680):02188                 LDD     [,U]
1776 EDC4             (fig-forth-auto680):02189                 STD     ,U
1778 39               (fig-forth-auto680):02190                 RTS
                      (fig-forth-auto680):02191         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):02192         *       LDX     0,X     get address
                      (fig-forth-auto680):02193         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02194         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02195         *       JMP     GETX
                      (fig-forth-auto680):02196         *
                      (fig-forth-auto680):02197         * ======>>  44  <<
                      (fig-forth-auto680):02198         * ( adr --- b )
                      (fig-forth-auto680):02199         * Replace address on top of stack with the byte at the address.
                      (fig-forth-auto680):02200         * High byte of result is clear.
1779 82               (fig-forth-auto680):02201                 FCB     $82
177A 43               (fig-forth-auto680):02202                 FCC     'C'     ; 'C@'
177B C0               (fig-forth-auto680):02203                 FCB     $C0
177C 176E             (fig-forth-auto680):02204                 FDB     AT-4
177E 1780             (fig-forth-auto680):02205         CAT     FDB     *+NATWID
1780 E6D4             (fig-forth-auto680):02206                 LDB     [,U]
1782 4F               (fig-forth-auto680):02207                 CLRA
1783 EDC4             (fig-forth-auto680):02208                 STD     ,U
1785 39               (fig-forth-auto680):02209                 RTS
                      (fig-forth-auto680):02210         
                      (fig-forth-auto680):02211         
                      (fig-forth-auto680):02212         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):02213         *       LDX     0,X
                      (fig-forth-auto680):02214         *       CLRA    ;
                      (fig-forth-auto680):02215         *       LDB 0,X
                      (fig-forth-auto680):02216         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02217         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02218         *       JMP     PUSHBA
                      (fig-forth-auto680):02219         *
                      (fig-forth-auto680):02220         * ======>>  45  <<
                      (fig-forth-auto680):02221         * ( n adr --- )
                      (fig-forth-auto680):02222         * Store second word on stack at address on top of stack.
1786 81               (fig-forth-auto680):02223                 FCB     $81
1787 A1               (fig-forth-auto680):02224                 FCB     $A1
1788 1779             (fig-forth-auto680):02225                 FDB     CAT-5
178A 178C             (fig-forth-auto680):02226         STORE   FDB     *+NATWID
178C EC42             (fig-forth-auto680):02227                 LDD     NATWID,U
178E EDD4             (fig-forth-auto680):02228                 STD     [,U]
1790 3344             (fig-forth-auto680):02229                 LEAU    2*NATWID,U
1792 39               (fig-forth-auto680):02230                 RTS
                      (fig-forth-auto680):02231         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):02232         *       LDX     0,X     get address
                      (fig-forth-auto680):02233         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02234         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02235         *       JMP     PULABX
                      (fig-forth-auto680):02236         *
                      (fig-forth-auto680):02237         * ======>>  46  <<
                      (fig-forth-auto680):02238         * ( b adr --- )
                      (fig-forth-auto680):02239         * Store low byte of second word on stack at address on top of stack. 
                      (fig-forth-auto680):02240         * High byte is ignored.
1793 82               (fig-forth-auto680):02241                 FCB     $82
1794 43               (fig-forth-auto680):02242                 FCC     'C'     ; 'C!'
1795 A1               (fig-forth-auto680):02243                 FCB     $A1
1796 1786             (fig-forth-auto680):02244                 FDB     STORE-4
1798 179A             (fig-forth-auto680):02245         CSTORE  FDB     *+NATWID
179A E643             (fig-forth-auto680):02246                 LDB     3,U
179C E7D4             (fig-forth-auto680):02247                 STB     [,U]
179E 3344             (fig-forth-auto680):02248                 LEAU    2*NATWID,U
17A0 39               (fig-forth-auto680):02249                 RTS
                      (fig-forth-auto680):02250         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):02251         *       LDX     0,X     get address
                      (fig-forth-auto680):02252         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02253         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02254         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02255         *       PULS B  ; 
                      (fig-forth-auto680):02256         *       STB 0,X
                      (fig-forth-auto680):02257         *       JMP     NEXT
                      (fig-forth-auto680):02258                 PAGE
                      (fig-forth-auto680):02259         *
                      (fig-forth-auto680):02260         * ######>> screen 33 <<
                      (fig-forth-auto680):02261         * ======>>  47  <<
                      (fig-forth-auto680):02262         * ( --- )                                                 P
                      (fig-forth-auto680):02263         * { : name sundry-activities ; } typical input
                      (fig-forth-auto680):02264         * If executing (not compiling), 
                      (fig-forth-auto680):02265         * record the data stack mark in CSP,
                      (fig-forth-auto680):02266         * Set the CONTEXT vocabulary to CURRENT,
                      (fig-forth-auto680):02267         * CREATE a header,
                      (fig-forth-auto680):02268         * set state to compile,
                      (fig-forth-auto680):02269         * and compile the call to the trailing native CPU machine code DOCOL.
                      (fig-forth-auto680):02270         *
                      (fig-forth-auto680):02271         * This would not be hard to flatten to native code.
                      (fig-forth-auto680):02272         * But that's not the purpose of a model.
17A1 C1               (fig-forth-auto680):02273                 FCB     $C1     : immediate
17A2 BA               (fig-forth-auto680):02274                 FCB     $BA
17A3 1793             (fig-forth-auto680):02275                 FDB     CSTORE-5
17A5 17B91B6A1B26194C (fig-forth-auto680):02276         COLON   FDB     DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
     1772193E178A
17B3 20661BEB         (fig-forth-auto680):02277                 FDB     CREATE,RBRAK
17B7 1C3A             (fig-forth-auto680):02278                 FDB     PSCODE
                      (fig-forth-auto680):02279         
                      (fig-forth-auto680):02280         * Here is the IP pusher for allowing
                      (fig-forth-auto680):02281         * nested words in the virtual machine:
                      (fig-forth-auto680):02282         * ( ;S is the equivalent un-nester )
                      (fig-forth-auto680):02283         
                      (fig-forth-auto680):02284         * ( *** oldIP ) 
                      (fig-forth-auto680):02285         * Characteristic of a colon (:) definition.  
                      (fig-forth-auto680):02286         * Begins execution of a high-level definition,
                      (fig-forth-auto680):02287         * i. e., nests the definition and begins processing icodes. 
                      (fig-forth-auto680):02288         * Mechanically, it pushes the IP (Y register)
                      (fig-forth-auto680):02289         * and loads the Parameter Field Address of the definition which
                      (fig-forth-auto680):02290         * called it into the IP.
17B9 ECE4             (fig-forth-auto680):02291         DOCOL   LDD     ,S      ; Save the return address.
17BB 10AFE4           (fig-forth-auto680):02292                 STY     ,S      ; Nest the old IP.
17BE 3102             (fig-forth-auto680):02293                 LEAY    NATWID,X        ; W still in X, bump to parameters, load as new IP.
17C0 1F05             (fig-forth-auto680):02294                 TFR     D,PC    ; synthetic return to interpret.
                      (fig-forth-auto680):02295         
                      (fig-forth-auto680):02296         * DOCOL LDX     RP      make room in the stack
                      (fig-forth-auto680):02297         *       LEAX -1,X       ; 
                      (fig-forth-auto680):02298         *       LEAX -1,X       ; 
                      (fig-forth-auto680):02299         *       STX     RP
                      (fig-forth-auto680):02300         *       LDA IP
                      (fig-forth-auto680):02301         *       LDB IP+1        
                      (fig-forth-auto680):02302         *       STA 2,X Store address of the high level word
                      (fig-forth-auto680):02303         *       STB 3,X that we are starting to execute
                      (fig-forth-auto680):02304         *       LDX     W       Get first sub-word of that definition
                      (fig-forth-auto680):02305         *       JMP     NEXT+2  and execute it
                      (fig-forth-auto680):02306         *
                      (fig-forth-auto680):02307         * ======>>  48  <<
                      (fig-forth-auto680):02308         * ( --- )                                                 P
                      (fig-forth-auto680):02309         * { : name sundry-activities ; } typical input
                      (fig-forth-auto680):02310         * ERROR check data stack against mark in CSP,
                      (fig-forth-auto680):02311         * compile ;S,
                      (fig-forth-auto680):02312         * unSMUDGE LATEST definition,
                      (fig-forth-auto680):02313         * and set state to interpretation.
17C2 C1               (fig-forth-auto680):02314                 FCB     $C1     ;   imnediate code
17C3 BB               (fig-forth-auto680):02315                 FCB     $BB
17C4 17A1             (fig-forth-auto680):02316                 FDB     COLON-4
17C6 17B91B921BC71667 (fig-forth-auto680):02317         SEMI    FDB     DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
     1BFF1BDD
17D2 1667             (fig-forth-auto680):02318                 FDB     SEMIS
                      (fig-forth-auto680):02319         *
                      (fig-forth-auto680):02320         * ######>> screen 34 <<
                      (fig-forth-auto680):02321         * ======>>  49  <<
                      (fig-forth-auto680):02322         * ( n --- )
                      (fig-forth-auto680):02323         * { value CONSTANT name } typical input
                      (fig-forth-auto680):02324         * CREATE a header,
                      (fig-forth-auto680):02325         * unSMUDGE it,
                      (fig-forth-auto680):02326         * compile the constant value,
                      (fig-forth-auto680):02327         * and compile the call to the trailing native CPU machine code DOCON.
17D4 88               (fig-forth-auto680):02328                 FCB     $88
17D5 434F4E5354414E   (fig-forth-auto680):02329                 FCC     'CONSTAN'       ; 'CONSTANT'
17DC D4               (fig-forth-auto680):02330                 FCB     $D4
17DD 17C2             (fig-forth-auto680):02331                 FDB     SEMI-4
17DF 17B920661BFF19E3 (fig-forth-auto680):02332         CON     FDB     DOCOL,CREATE,SMUDGE,COMMA,PSCODE
     1C3A
                      (fig-forth-auto680):02333         * ( --- n ) 
                      (fig-forth-auto680):02334         * Characteristic of a CONSTANT. 
                      (fig-forth-auto680):02335         * A CONSTANT simply loads its value from its parameter field
                      (fig-forth-auto680):02336         * and pushes it on the stack.
17E9 EC02             (fig-forth-auto680):02337         DOCON   LDD     NATWID,X        ; Get the first natural width word of the parameter field.
17EB 3606             (fig-forth-auto680):02338                 PSHU    D
17ED 39               (fig-forth-auto680):02339                 RTS
                      (fig-forth-auto680):02340         * DOCON LDX     W
                      (fig-forth-auto680):02341         *       LDA 2,X 
                      (fig-forth-auto680):02342         *       LDB 3,X A & B now contain the constant
                      (fig-forth-auto680):02343         *       JMP     PUSHBA
                      (fig-forth-auto680):02344         *
                      (fig-forth-auto680):02345         * Not in model, needed for abstraction:
                      (fig-forth-auto680):02346         * ( --- NATWID )
                      (fig-forth-auto680):02347         * The byte width of objects on stack.
17EE 86               (fig-forth-auto680):02348                 FCB     $86
17EF 4E41545749       (fig-forth-auto680):02349                 FCC     'NATWI' ; 'NATWID'
17F4 C4               (fig-forth-auto680):02350                 FCB     $C4
17F5 17D4             (fig-forth-auto680):02351                 FDB     CON-11
17F7 17E9             (fig-forth-auto680):02352         NATWC   FDB     DOCON
17F9 0002             (fig-forth-auto680):02353         NATWCV  FDB     NATWID
                      (fig-forth-auto680):02354         *
                      (fig-forth-auto680):02355         * Not in model, needed for abstraction:
                      (fig-forth-auto680):02356         * Note that this is not defined as an INCREMENTER!
                      (fig-forth-auto680):02357         * Coded to increment by the exact constant returned by NATWID
                      (fig-forth-auto680):02358         * ( n --- n+NATWID )
17FB 84               (fig-forth-auto680):02359                 FCB     $84
17FC 4E4154           (fig-forth-auto680):02360                 FCC     'NAT'   ; 'NAT+'
17FF AB               (fig-forth-auto680):02361                 FCB     $AB
1800 17EE             (fig-forth-auto680):02362                 FDB     NATWC-9
1802 1804             (fig-forth-auto680):02363         NATP    FDB     *+NATWID
1804 ECC4             (fig-forth-auto680):02364                 LDD     ,U
1806 E38CF0           (fig-forth-auto680):02365                 ADDD    NATWCV,PCR      ; Looking ahead, does not have to be PCRelative.
1809 EDC4             (fig-forth-auto680):02366                 STD     ,U
180B 39               (fig-forth-auto680):02367                 RTS
                      (fig-forth-auto680):02368         * How this might have been done for 6800 model:
                      (fig-forth-auto680):02369         *       CLRA    ; We know the natural width is less than 255, LOL.
                      (fig-forth-auto680):02370         *       LDAB    NATWCV+1
                      (fig-forth-auto680):02371         *       TSX
                      (fig-forth-auto680):02372         *       ADDB    1,X
                      (fig-forth-auto680):02373         *       ADCA    ,X
                      (fig-forth-auto680):02374         *       JMP     STABX
                      (fig-forth-auto680):02375         *
                      (fig-forth-auto680):02376         * ======>>  50  <<
                      (fig-forth-auto680):02377         * ( init --- )
                      (fig-forth-auto680):02378         * { init VARIABLE name } typical input
                      (fig-forth-auto680):02379         * Use CONSTANT to CREATE a header and compile the initial value, init, 
                      (fig-forth-auto680):02380         * then overwrite the characteristic to point to DOVAR.
180C 88               (fig-forth-auto680):02381                 FCB     $88
180D 5641524941424C   (fig-forth-auto680):02382                 FCC     'VARIABL'       ; 'VARIABLE'
1814 C5               (fig-forth-auto680):02383                 FCB     $C5
1815 17FB             (fig-forth-auto680):02384                 FDB     NATP-7
1817 17B917DF1C3A     (fig-forth-auto680):02385         VAR     FDB     DOCOL,CON,PSCODE
                      (fig-forth-auto680):02386         * ( --- vadr ) 
                      (fig-forth-auto680):02387         * Characteristic of a VARIABLE. 
                      (fig-forth-auto680):02388         * A VARIABLE pushes its PFA address on the stack. 
                      (fig-forth-auto680):02389         * The parameter field of a VARIABLE is the actual allocation of the variable,
                      (fig-forth-auto680):02390         * so that pushing its address allows its contents to be @ed (fetched). 
                      (fig-forth-auto680):02391         * Ordinary arrays and strings that do not subscript themselves
                      (fig-forth-auto680):02392         * may be allocated by defining a variable
                      (fig-forth-auto680):02393         * and immediately ALLOTting the remaining needed space.
                      (fig-forth-auto680):02394         * VARIABLES are global to all users,
                      (fig-forth-auto680):02395         * and thus should be hidden in resource monitors, but aren't.
181D 3002             (fig-forth-auto680):02396         DOVAR   LEAX    NATWID,X        ; Point to the first natural width word of the parameters.
181F 3610             (fig-forth-auto680):02397                 PSHU    X
1821 39               (fig-forth-auto680):02398                 RTS
                      (fig-forth-auto680):02399         * DOVAR LDA W
                      (fig-forth-auto680):02400         *       LDB W+1
                      (fig-forth-auto680):02401         *       ADDB #2
                      (fig-forth-auto680):02402         *       ADCA #0 A,B now contain the address of the variable
                      (fig-forth-auto680):02403         *       JMP     PUSHBA
                      (fig-forth-auto680):02404         *
                      (fig-forth-auto680):02405         * ======>>  51  <<
                      (fig-forth-auto680):02406         * ( ub --- )
                      (fig-forth-auto680):02407         * { uboffset USER name } typical input
                      (fig-forth-auto680):02408         * CREATE a header and compile the unsigned byte offset in the per-USER table, 
                      (fig-forth-auto680):02409         * then overwrite the header with a call to DOUSER.
                      (fig-forth-auto680):02410         * The USER is entirely responsible for maintaining allocation!
1822 84               (fig-forth-auto680):02411                 FCB     $84
1823 555345           (fig-forth-auto680):02412                 FCC     'USE'   ; 'USER'
1826 D2               (fig-forth-auto680):02413                 FCB     $D2
1827 180C             (fig-forth-auto680):02414                 FDB     VAR-11
1829 17B917DF1C3A     (fig-forth-auto680):02415         USER    FDB     DOCOL,CON,PSCODE
                      (fig-forth-auto680):02416         * ( --- vadr ) 
                      (fig-forth-auto680):02417         * Characteristic of a per-USER variable. 
                      (fig-forth-auto680):02418         * USER variables are similiar to VARIABLEs,
                      (fig-forth-auto680):02419         * but are allocated (by hand!) in the per-user table. 
                      (fig-forth-auto680):02420         * A USER variable's parameter field contains its offset in the per-user table.
182F 1FB8             (fig-forth-auto680):02421         DOUSER  TFR     DP,A    ; Make a pointer to the direct page.
1831 5F               (fig-forth-auto680):02422                 CLRB
                      (fig-forth-auto680):02423         *       See Alternative -- alternatives start from this point.
1832 E302             (fig-forth-auto680):02424                 ADDD    NATWID,X        ; Add it to the offset to the per-user variable.
1834 3606             (fig-forth-auto680):02425                 PSHU    D
1836 1F01             (fig-forth-auto680):02426                 TFR     D,X     ; Cache the pointer in X for the caller.
1838 39               (fig-forth-auto680):02427                 RTS
                      (fig-forth-auto680):02428         * Hey, the per-user table could actually be larger than 256 bytes!
                      (fig-forth-auto680):02429         * But we knew that. It's just not as esthetic to calculate it this way.
                      (fig-forth-auto680):02430         * Alternative A:
                      (fig-forth-auto680):02431         *       LDX     NATWID,X        ; Keep the offset
                      (fig-forth-auto680):02432         *       EXG     D,X     ; Prepare for EA 
                      (fig-forth-auto680):02433         *       LEAX    D,X
                      (fig-forth-auto680):02434         *       PSHU    X
                      (fig-forth-auto680):02435         *       RTS
                      (fig-forth-auto680):02436         * Alternative B:
                      (fig-forth-auto680):02437         *       PSHS    Y       ; Get Y free for calculations.
                      (fig-forth-auto680):02438         *       TFR     D,Y     ; Y points to the UP base
                      (fig-forth-auto680):02439         *       LDD     NATWID,X        ; Get the offset
                      (fig-forth-auto680):02440         *       LEAX    D,Y     ; Leave the pointer cached in X.
                      (fig-forth-auto680):02441         *       PSHU    X
                      (fig-forth-auto680):02442         *       PULS    Y,PC
                      (fig-forth-auto680):02443         *
                      (fig-forth-auto680):02444         * From the 6800 model:
                      (fig-forth-auto680):02445         * DOUSER        LDX     W       get offset  into user's table
                      (fig-forth-auto680):02446         *       LDA 2,X
                      (fig-forth-auto680):02447         *       LDB 3,X
                      (fig-forth-auto680):02448         *       ADDB UP+1       add to users base address
                      (fig-forth-auto680):02449         *       ADCA UP
                      (fig-forth-auto680):02450         *       JMP     PUSHBA  push address of user's variable
                      (fig-forth-auto680):02451         *
                      (fig-forth-auto680):02452         * ######>> screen 35 <<
                      (fig-forth-auto680):02453         * ======>>  52  <<
                      (fig-forth-auto680):02454         * ( --- 0 )
1839 81               (fig-forth-auto680):02455                 FCB     $81
183A B0               (fig-forth-auto680):02456                 FCB     $B0     0
183B 1822             (fig-forth-auto680):02457                 FDB     USER-7
183D 17E9             (fig-forth-auto680):02458         ZERO    FDB     DOCON
183F 0000             (fig-forth-auto680):02459                 FDB     0000
                      (fig-forth-auto680):02460         *
                      (fig-forth-auto680):02461         * ======>>  53  <<
                      (fig-forth-auto680):02462         * ( --- 1 )
1841 81               (fig-forth-auto680):02463                 FCB     $81
1842 B1               (fig-forth-auto680):02464                 FCB     $B1     1
1843 1839             (fig-forth-auto680):02465                 FDB     ZERO-4
1845 17E9             (fig-forth-auto680):02466         ONE     FDB     DOCON
1847 0001             (fig-forth-auto680):02467         ONEV    FDB     1
                      (fig-forth-auto680):02468         *
                      (fig-forth-auto680):02469         * ======>>  54  <<
                      (fig-forth-auto680):02470         * ( --- 2 )
1849 81               (fig-forth-auto680):02471                 FCB     $81
184A B2               (fig-forth-auto680):02472                 FCB     $B2     2
184B 1841             (fig-forth-auto680):02473                 FDB     ONE-4
184D 17E9             (fig-forth-auto680):02474         TWO     FDB     DOCON
184F 0002             (fig-forth-auto680):02475         TWOV    FDB     2
                      (fig-forth-auto680):02476         *
                      (fig-forth-auto680):02477         * ======>>  55  <<
                      (fig-forth-auto680):02478         * ( --- 3 )
1851 81               (fig-forth-auto680):02479                 FCB     $81
1852 B3               (fig-forth-auto680):02480                 FCB     $B3     3
1853 1849             (fig-forth-auto680):02481                 FDB     TWO-4
1855 17E9             (fig-forth-auto680):02482         THREE   FDB     DOCON
1857 0003             (fig-forth-auto680):02483                 FDB     3
                      (fig-forth-auto680):02484         *
                      (fig-forth-auto680):02485         * ======>>  56  <<
                      (fig-forth-auto680):02486         * ( --- SP ) 
                      (fig-forth-auto680):02487         * ASCII SPACE character
1859 82               (fig-forth-auto680):02488                 FCB     $82
185A 42               (fig-forth-auto680):02489                 FCC     'B'     ; 'BL'
185B CC               (fig-forth-auto680):02490                 FCB     $CC
185C 1851             (fig-forth-auto680):02491                 FDB     THREE-4
185E 17E9             (fig-forth-auto680):02492         BL      FDB     DOCON   ascii blank
1860 0020             (fig-forth-auto680):02493                 FDB     $20
                      (fig-forth-auto680):02494         *
                      (fig-forth-auto680):02495         * ======>>  57  <<
                      (fig-forth-auto680):02496         * This really shouldn't be a CONSTANT.
                      (fig-forth-auto680):02497         * ( --- adr )    
                      (fig-forth-auto680):02498         * The base of the disk buffer space.
1862 85               (fig-forth-auto680):02499                 FCB     $85
1863 46495253         (fig-forth-auto680):02500                 FCC     'FIRS'  ; 'FIRST'
1867 D4               (fig-forth-auto680):02501                 FCB     $D4
1868 1859             (fig-forth-auto680):02502                 FDB     BL-5
186A 17E9             (fig-forth-auto680):02503         FIRST   FDB     DOCON
186C 6BE0             (fig-forth-auto680):02504                 FDB     BUFBAS
                      (fig-forth-auto680):02505         *       FDB     MEMEND-528      (132 * NBLK)
                      (fig-forth-auto680):02506         *
                      (fig-forth-auto680):02507         * ======>>  58  <<
                      (fig-forth-auto680):02508         * This really shouldn't be a CONSTANT.
                      (fig-forth-auto680):02509         * ( --- adr ) 
                      (fig-forth-auto680):02510         * The limit of the disk buffer space.
186E 85               (fig-forth-auto680):02511                 FCB     $85
186F 4C494D49         (fig-forth-auto680):02512                 FCC     'LIMI'  ; 'LIMIT' :     ( the end of memory +1 )
1873 D4               (fig-forth-auto680):02513                 FCB     $D4
1874 1862             (fig-forth-auto680):02514                 FDB     FIRST-8
1876 17E9             (fig-forth-auto680):02515         LIMIT   FDB     DOCON
1878 7000             (fig-forth-auto680):02516                 FDB     BUFBAS+BUFSZ
                      (fig-forth-auto680):02517         * In 6800 model, was
                      (fig-forth-auto680):02518         *       FDB     MEMEND
                      (fig-forth-auto680):02519         *
                      (fig-forth-auto680):02520         * ======>>  59  <<
                      (fig-forth-auto680):02521         * ( --- sectorsize )
                      (fig-forth-auto680):02522         * The size, in bytes, of a buffer.
187A 85               (fig-forth-auto680):02523                 FCB     $85
187B 422F4255         (fig-forth-auto680):02524                 FCC     'B/BU'  ; 'B/BUF' :     (bytes/buffer)
187F C6               (fig-forth-auto680):02525                 FCB     $C6
1880 186E             (fig-forth-auto680):02526                 FDB     LIMIT-8
1882 17E9             (fig-forth-auto680):02527         BBUF    FDB     DOCON
1884 0100             (fig-forth-auto680):02528                 FDB     SECTSZ
                      (fig-forth-auto680):02529         * Hardcoded in 6800 model:
                      (fig-forth-auto680):02530         *       FDB     128
                      (fig-forth-auto680):02531         *
                      (fig-forth-auto680):02532         * ======>>  60  <<
                      (fig-forth-auto680):02533         * ( --- blocksperscreen )      
                      (fig-forth-auto680):02534         * The size, in blocks, of a screen.
                      (fig-forth-auto680):02535         * Should this be the same as NBLK, the number of block buffers maintained?
1886 85               (fig-forth-auto680):02536                 FCB     $85
1887 422F5343         (fig-forth-auto680):02537                 FCC     'B/SC'  ; 'B/SCR' :     (blocks/screen)
188B D2               (fig-forth-auto680):02538                 FCB     $D2
188C 187A             (fig-forth-auto680):02539                 FDB     BBUF-8
188E 17E9             (fig-forth-auto680):02540         BSCR    FDB     DOCON
1890 0004             (fig-forth-auto680):02541                 FDB     SCRSZ/SECTSZ
                      (fig-forth-auto680):02542         * Hardcoded in 6800 model as:
                      (fig-forth-auto680):02543         *       FDB     8
                      (fig-forth-auto680):02544         *       blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
                      (fig-forth-auto680):02545         *
                      (fig-forth-auto680):02546         * ======>>  61  <<
                      (fig-forth-auto680):02547         * ( n --- adr )
                      (fig-forth-auto680):02548         * Calculate the address of entry (#n/2) in the boot-up parameter table. 
                      (fig-forth-auto680):02549         * (Adds the base of the boot-up table to n.)
1892 87               (fig-forth-auto680):02550                 FCB     $87
1893 2B4F52494749     (fig-forth-auto680):02551                 FCC     '+ORIGI'        ; '+ORIGIN'
1899 CE               (fig-forth-auto680):02552                 FCB     $CE
189A 1886             (fig-forth-auto680):02553                 FDB     BSCR-8
189C 17B91399120016C6 (fig-forth-auto680):02554         PORIG   FDB     DOCOL,LIT,ORIG,PLUS
18A4 1667             (fig-forth-auto680):02555                 FDB     SEMIS
                      (fig-forth-auto680):02556         *
                      (fig-forth-auto680):02557         * ######>> screen 36 <<
                      (fig-forth-auto680):02558         * ======>>  62  <<
                      (fig-forth-auto680):02559         * ( n --- adr )
                      (fig-forth-auto680):02560         * This is the per-task variable recording the initial parameter stack pointer.
18A6 82               (fig-forth-auto680):02561                 FCB     $82
18A7 53               (fig-forth-auto680):02562                 FCC     'S'     ; 'S0'
18A8 B0               (fig-forth-auto680):02563                 FCB     $B0
18A9 1892             (fig-forth-auto680):02564                 FDB     PORIG-10
18AB 182F             (fig-forth-auto680):02565         SZERO   FDB     DOUSER
18AD 001E             (fig-forth-auto680):02566                 FDB     XSPZER-UORIG
                      (fig-forth-auto680):02567         *
                      (fig-forth-auto680):02568         * ======>>  63  <<
                      (fig-forth-auto680):02569         * ( n --- adr )
                      (fig-forth-auto680):02570         * This is the per-task variable recording the initial return stack pointer.
18AF 82               (fig-forth-auto680):02571                 FCB     $82
18B0 52               (fig-forth-auto680):02572                 FCC     'R'     ; 'R0'
18B1 B0               (fig-forth-auto680):02573                 FCB     $B0
18B2 18A6             (fig-forth-auto680):02574                 FDB     SZERO-5
18B4 182F             (fig-forth-auto680):02575         RZERO   FDB     DOUSER
18B6 0020             (fig-forth-auto680):02576                 FDB     XRZERO-UORIG
                      (fig-forth-auto680):02577         *
                      (fig-forth-auto680):02578         * ======>>  64  <<
                      (fig-forth-auto680):02579         * ( --- vadr )   
                      (fig-forth-auto680):02580         * Terminal Input Buffer address. 
                      (fig-forth-auto680):02581         * Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
18B8 83               (fig-forth-auto680):02582                 FCB     $83
18B9 5449             (fig-forth-auto680):02583                 FCC     'TI'    ; 'TIB'
18BB C2               (fig-forth-auto680):02584                 FCB     $C2
18BC 18AF             (fig-forth-auto680):02585                 FDB     RZERO-5
18BE 182F             (fig-forth-auto680):02586         TIB     FDB     DOUSER
18C0 0022             (fig-forth-auto680):02587                 FDB     XTIB-UORIG
                      (fig-forth-auto680):02588         *
                      (fig-forth-auto680):02589         * ======>>  65  <<
                      (fig-forth-auto680):02590         * ( --- maxnamewidth )
                      (fig-forth-auto680):02591         * This is the maximum width to which symbol names will be recorded.
18C2 85               (fig-forth-auto680):02592                 FCB     $85
18C3 57494454         (fig-forth-auto680):02593                 FCC     'WIDT'  ; 'WIDTH'
18C7 C8               (fig-forth-auto680):02594                 FCB     $C8
18C8 18B8             (fig-forth-auto680):02595                 FDB     TIB-6
18CA 182F             (fig-forth-auto680):02596         WIDTH   FDB     DOUSER
18CC 0024             (fig-forth-auto680):02597                 FDB     XWIDTH-UORIG
                      (fig-forth-auto680):02598         *
                      (fig-forth-auto680):02599         * ======>>  66  <<
                      (fig-forth-auto680):02600         * ( --- vadr )   
                      (fig-forth-auto680):02601         * Availability of error messages on disk.
                      (fig-forth-auto680):02602         * Contains 1 if messages available, 
                      (fig-forth-auto680):02603         * 0 if not,
                      (fig-forth-auto680):02604         * -1 if a disk error has occurred.
18CE 87               (fig-forth-auto680):02605                 FCB     $87
18CF 5741524E494E     (fig-forth-auto680):02606                 FCC     'WARNIN'        ; 'WARNING'
18D5 C7               (fig-forth-auto680):02607                 FCB     $C7
18D6 18C2             (fig-forth-auto680):02608                 FDB     WIDTH-8
18D8 182F             (fig-forth-auto680):02609         WARN    FDB     DOUSER
18DA 0026             (fig-forth-auto680):02610                 FDB     XWARN-UORIG
                      (fig-forth-auto680):02611         *
                      (fig-forth-auto680):02612         * ======>>  67  <<
                      (fig-forth-auto680):02613         * ( --- vadr )   
                      (fig-forth-auto680):02614         * Boundary for FORGET.
18DC 85               (fig-forth-auto680):02615                 FCB     $85
18DD 46454E43         (fig-forth-auto680):02616                 FCC     'FENC'  ; 'FENCE'
18E1 C5               (fig-forth-auto680):02617                 FCB     $C5
18E2 18CE             (fig-forth-auto680):02618                 FDB     WARN-10
18E4 182F             (fig-forth-auto680):02619         FENCE   FDB     DOUSER
18E6 0028             (fig-forth-auto680):02620                 FDB     XFENCE-UORIG
                      (fig-forth-auto680):02621         *
                      (fig-forth-auto680):02622         * ======>>  68  <<
                      (fig-forth-auto680):02623         * ( --- vadr )   
                      (fig-forth-auto680):02624         * Dictionary pointer, fetched by HERE.
18E8 82               (fig-forth-auto680):02625                 FCB     $82
18E9 44               (fig-forth-auto680):02626                 FCC     'D'     ; 'DP' :        points to first free byte at end of dictionary
18EA D0               (fig-forth-auto680):02627                 FCB     $D0
18EB 18DC             (fig-forth-auto680):02628                 FDB     FENCE-8
18ED 182F             (fig-forth-auto680):02629         DICTPT  FDB     DOUSER
18EF 002A             (fig-forth-auto680):02630                 FDB     XDICTP-UORIG
                      (fig-forth-auto680):02631         *
                      (fig-forth-auto680):02632         * ======>>  68.5  <<
                      (fig-forth-auto680):02633         * ( --- vadr ) ******* Need to check what this is!
                      (fig-forth-auto680):02634         * Used in maintaining vocabularies.
                      (fig-forth-auto680):02635         * I think it points to the "parent" vocabulary, but I'm not sure.
                      (fig-forth-auto680):02636         * Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
18F1 88               (fig-forth-auto680):02637                 FCB     $88
18F2 564F432D4C494E   (fig-forth-auto680):02638                 FCC     'VOC-LIN'       ; 'VOC-LINK'
18F9 CB               (fig-forth-auto680):02639                 FCB     $CB
18FA 18E8             (fig-forth-auto680):02640                 FDB     DICTPT-5
18FC 182F             (fig-forth-auto680):02641         VOCLIN  FDB     DOUSER
18FE 002C             (fig-forth-auto680):02642                 FDB     XVOCL-UORIG
                      (fig-forth-auto680):02643         *
                      (fig-forth-auto680):02644         * ======>>  69  <<
                      (fig-forth-auto680):02645         * ( --- vadr )   
                      (fig-forth-auto680):02646         * Disk block being interpreted. 
                      (fig-forth-auto680):02647         * Zero refers to terminal.
                      (fig-forth-auto680):02648         * ******** Should be made a 32 bit user variable! ********
                      (fig-forth-auto680):02649         * But the base system needs to have full 32 bit support, div and mul, etc.
                      (fig-forth-auto680):02650         * before we can do that.
1900 83               (fig-forth-auto680):02651                 FCB     $83
1901 424C             (fig-forth-auto680):02652                 FCC     'BL'    ; 'BLK'
1903 CB               (fig-forth-auto680):02653                 FCB     $CB
1904 18F1             (fig-forth-auto680):02654                 FDB     VOCLIN-11
1906 182F             (fig-forth-auto680):02655         BLK     FDB     DOUSER
1908 002E             (fig-forth-auto680):02656                 FDB     XBLK-UORIG
                      (fig-forth-auto680):02657         *
                      (fig-forth-auto680):02658         * ======>>  70  <<
                      (fig-forth-auto680):02659         * ( --- vadr )   
                      (fig-forth-auto680):02660         * Input buffer offset/cursor.
190A 82               (fig-forth-auto680):02661                 FCB     $82
190B 49               (fig-forth-auto680):02662                 FCC     'I'     ; 'IN' :        scan pointer for input line buffer
190C CE               (fig-forth-auto680):02663                 FCB     $CE
190D 1900             (fig-forth-auto680):02664                 FDB     BLK-6
190F 182F             (fig-forth-auto680):02665         IN      FDB     DOUSER
1911 0030             (fig-forth-auto680):02666                 FDB     XIN-UORIG
                      (fig-forth-auto680):02667         *
                      (fig-forth-auto680):02668         * ======>>  71  <<
                      (fig-forth-auto680):02669         * ( --- vadr )   
                      (fig-forth-auto680):02670         * Output buffer offset/cursor.
1913 83               (fig-forth-auto680):02671                 FCB     $83
1914 4F55             (fig-forth-auto680):02672                 FCC     'OU'    ; 'OUT'
1916 D4               (fig-forth-auto680):02673                 FCB     $D4
1917 190A             (fig-forth-auto680):02674                 FDB     IN-5
1919 182F             (fig-forth-auto680):02675         OUT     FDB     DOUSER
191B 0032             (fig-forth-auto680):02676                 FDB     XOUT-UORIG
                      (fig-forth-auto680):02677         *
                      (fig-forth-auto680):02678         * ======>>  72  <<
                      (fig-forth-auto680):02679         * ( --- vadr )   
                      (fig-forth-auto680):02680         * Screen currently being edited, once we have an editor running. 
191D 83               (fig-forth-auto680):02681                 FCB     $83
191E 5343             (fig-forth-auto680):02682                 FCC     'SC'    ; 'SCR'
1920 D2               (fig-forth-auto680):02683                 FCB     $D2
1921 1913             (fig-forth-auto680):02684                 FDB     OUT-6
1923 182F             (fig-forth-auto680):02685         SCR     FDB     DOUSER
1925 0034             (fig-forth-auto680):02686                 FDB     XSCR-UORIG
                      (fig-forth-auto680):02687         * ######>> screen 37 <<
                      (fig-forth-auto680):02688         *
                      (fig-forth-auto680):02689         * ======>>  73  <<
                      (fig-forth-auto680):02690         * ( --- vadr )   
                      (fig-forth-auto680):02691         * Sector offset for LOADing screens,
                      (fig-forth-auto680):02692         * set by DRIVE to make a new drive the default.
                      (fig-forth-auto680):02693         * This should also be 32 bit or bigger.
1927 86               (fig-forth-auto680):02694                 FCB     $86
1928 4F46465345       (fig-forth-auto680):02695                 FCC     'OFFSE' ; 'OFFSET'
192D D4               (fig-forth-auto680):02696                 FCB     $D4
192E 191D             (fig-forth-auto680):02697                 FDB     SCR-6
1930 182F             (fig-forth-auto680):02698         OFSET   FDB     DOUSER
1932 0036             (fig-forth-auto680):02699                 FDB     XOFSET-UORIG
                      (fig-forth-auto680):02700         *
                      (fig-forth-auto680):02701         * ======>>  74  <<
                      (fig-forth-auto680):02702         * ( --- vadr )   
                      (fig-forth-auto680):02703         * Current context of interpretation (vocabulary root).
1934 87               (fig-forth-auto680):02704                 FCB     $87
1935 434F4E544558     (fig-forth-auto680):02705                 FCC     'CONTEX'        ; 'CONTEXT' :   points to pointer to vocab to search first
193B D4               (fig-forth-auto680):02706                 FCB     $D4
193C 1927             (fig-forth-auto680):02707                 FDB     OFSET-9
193E 182F             (fig-forth-auto680):02708         CONTXT  FDB     DOUSER
1940 0038             (fig-forth-auto680):02709                 FDB     XCONT-UORIG
                      (fig-forth-auto680):02710         *
                      (fig-forth-auto680):02711         * ======>>  75  <<
                      (fig-forth-auto680):02712         * ( --- vadr )   
                      (fig-forth-auto680):02713         * Current context of definition (vocabulary root).
1942 87               (fig-forth-auto680):02714                 FCB     $87
1943 43555252454E     (fig-forth-auto680):02715                 FCC     'CURREN'        ; 'CURRENT' :   points to ptr. to vocab being extended
1949 D4               (fig-forth-auto680):02716                 FCB     $D4
194A 1934             (fig-forth-auto680):02717                 FDB     CONTXT-10
194C 182F             (fig-forth-auto680):02718         CURENT  FDB     DOUSER
194E 003A             (fig-forth-auto680):02719                 FDB     XCURR-UORIG
                      (fig-forth-auto680):02720         *
                      (fig-forth-auto680):02721         * ======>>  76  <<
                      (fig-forth-auto680):02722         * ( --- vadr )   
                      (fig-forth-auto680):02723         * Compiler/interpreter state.
1950 85               (fig-forth-auto680):02724                 FCB     $85
1951 53544154         (fig-forth-auto680):02725                 FCC     'STAT'  ; 'STATE' :     1 if compiling, 0 if not
1955 C5               (fig-forth-auto680):02726                 FCB     $C5
1956 1942             (fig-forth-auto680):02727                 FDB     CURENT-10
1958 182F             (fig-forth-auto680):02728         STATE   FDB     DOUSER
195A 003C             (fig-forth-auto680):02729                 FDB     XSTATE-UORIG
                      (fig-forth-auto680):02730         *
                      (fig-forth-auto680):02731         * ======>>  77  <<
                      (fig-forth-auto680):02732         * ( --- vadr )   
                      (fig-forth-auto680):02733         * Numeric conversion base.
195C 84               (fig-forth-auto680):02734                 FCB     $84
195D 424153           (fig-forth-auto680):02735                 FCC     'BAS'   ; 'BASE' :      number base for all input & output
1960 C5               (fig-forth-auto680):02736                 FCB     $C5
1961 1950             (fig-forth-auto680):02737                 FDB     STATE-8
1963 182F             (fig-forth-auto680):02738         BASE    FDB     DOUSER
1965 003E             (fig-forth-auto680):02739                 FDB     XBASE-UORIG
                      (fig-forth-auto680):02740         *
                      (fig-forth-auto680):02741         * ======>>  78  <<
                      (fig-forth-auto680):02742         * ( --- vadr ) 
                      (fig-forth-auto680):02743         * Decimal point location for output.
1967 83               (fig-forth-auto680):02744                 FCB     $83
1968 4450             (fig-forth-auto680):02745                 FCC     'DP'    ; 'DPL'
196A CC               (fig-forth-auto680):02746                 FCB     $CC
196B 195C             (fig-forth-auto680):02747                 FDB     BASE-7
196D 182F             (fig-forth-auto680):02748         DPL     FDB     DOUSER
196F 0040             (fig-forth-auto680):02749                 FDB     XDPL-UORIG
                      (fig-forth-auto680):02750         *
                      (fig-forth-auto680):02751         * ======>>  79  <<
                      (fig-forth-auto680):02752         * ( --- vadr )   
                      (fig-forth-auto680):02753         * Field width for I/O formatting.
1971 83               (fig-forth-auto680):02754                 FCB     $83
1972 464C             (fig-forth-auto680):02755                 FCC     'FL'    ; 'FLD'
1974 C4               (fig-forth-auto680):02756                 FCB     $C4
1975 1967             (fig-forth-auto680):02757                 FDB     DPL-6
1977 182F             (fig-forth-auto680):02758         FLD     FDB     DOUSER
1979 0042             (fig-forth-auto680):02759                 FDB     XFLD-UORIG
                      (fig-forth-auto680):02760         *
                      (fig-forth-auto680):02761         * ======>>  80  <<
                      (fig-forth-auto680):02762         * ( --- vadr )   
                      (fig-forth-auto680):02763         * Compiler stack mark for stack check.
197B 83               (fig-forth-auto680):02764                 FCB     $83
197C 4353             (fig-forth-auto680):02765                 FCC     'CS'    ; 'CSP'
197E D0               (fig-forth-auto680):02766                 FCB     $D0
197F 1971             (fig-forth-auto680):02767                 FDB     FLD-6
1981 182F             (fig-forth-auto680):02768         CSP     FDB     DOUSER
1983 0044             (fig-forth-auto680):02769                 FDB     XCSP-UORIG
                      (fig-forth-auto680):02770         *
                      (fig-forth-auto680):02771         * ======>>  81  <<
                      (fig-forth-auto680):02772         * ( --- vadr )   
                      (fig-forth-auto680):02773         * Editing cursor location. 
1985 82               (fig-forth-auto680):02774                 FCB     $82
1986 52               (fig-forth-auto680):02775                 FCC     'R'     ; 'R#'
1987 A3               (fig-forth-auto680):02776                 FCB     $A3
1988 197B             (fig-forth-auto680):02777                 FDB     CSP-6
198A 182F             (fig-forth-auto680):02778         RNUM    FDB     DOUSER
198C 0046             (fig-forth-auto680):02779                 FDB     XRNUM-UORIG
                      (fig-forth-auto680):02780         *
                      (fig-forth-auto680):02781         * ======>>  82  <<
                      (fig-forth-auto680):02782         * ( --- vadr )   
                      (fig-forth-auto680):02783         * Pointer to last HELD character in PAD.
198E 83               (fig-forth-auto680):02784                 FCB     $83
198F 484C             (fig-forth-auto680):02785                 FCC     'HL'    ; 'HLD'
1991 C4               (fig-forth-auto680):02786                 FCB     $C4
1992 1985             (fig-forth-auto680):02787                 FDB     RNUM-5
1994 17E9             (fig-forth-auto680):02788         HLD     FDB     DOCON
1996 7C48             (fig-forth-auto680):02789                 FDB     XHLD
                      (fig-forth-auto680):02790         *
                      (fig-forth-auto680):02791         * ======>>  82.5  <<== SPECIAL
                      (fig-forth-auto680):02792         * ( --- vadr )   
                      (fig-forth-auto680):02793         * Line width of active terminal.
1998 87               (fig-forth-auto680):02794                 FCB     $87
1999 434F4C554D4E     (fig-forth-auto680):02795                 FCC     'COLUMN'        ; 'COLUMNS' :   line width of terminal
199F D3               (fig-forth-auto680):02796                 FCB     $D3
19A0 198E             (fig-forth-auto680):02797                 FDB     HLD-6
19A2 182F             (fig-forth-auto680):02798         COLUMS  FDB     DOUSER
19A4 004C             (fig-forth-auto680):02799                 FDB     XCOLUM-UORIG
                      (fig-forth-auto680):02800         *
                      (fig-forth-auto680):02801         * ######>> screen 38 <<
                      (fig-forth-auto680):02802         **
                      (fig-forth-auto680):02803         ** An INCREMENTER probably should not be defined without a defined CONSTANT?
                      (fig-forth-auto680):02804         **
                      (fig-forth-auto680):02805         ** Make an INCREMENTER compiling word (not in model):
                      (fig-forth-auto680):02806         ** ( n --- )
                      (fig-forth-auto680):02807         ** { n INCREMENTER name } typical input
                      (fig-forth-auto680):02808         ** CREATE a header and compile the increment constant, 
                      (fig-forth-auto680):02809         ** then overwrite the header with a call to DOINC.
                      (fig-forth-auto680):02810         *       FCB     $8B
                      (fig-forth-auto680):02811         *       FCC     'INCREMENTE'    ; 'INCREMENTER'
                      (fig-forth-auto680):02812         *       FCB     $D2
                      (fig-forth-auto680):02813         *       FDB     COLUMS-10
                      (fig-forth-auto680):02814         * INCR  FDB     DOCOL,CON,PSCODE
                      (fig-forth-auto680):02815         ** ( n --- ninc ) 
                      (fig-forth-auto680):02816         ** Characteristic of an INCREMENTER.
                      (fig-forth-auto680):02817         ** This is too naive:
                      (fig-forth-auto680):02818         * DOINC LDD     ,U
                      (fig-forth-auto680):02819         *       ADDD    NATWID,X        ; Add the increment.
                      (fig-forth-auto680):02820         *       STD     ,U
                      (fig-forth-auto680):02821         *       RTS
                      (fig-forth-auto680):02822         * Compiling word should check that it is compiling a CONSTANT.
                      (fig-forth-auto680):02823         *
                      (fig-forth-auto680):02824         * ======>>  83  <<
                      (fig-forth-auto680):02825         * ( n --- n+1 )
19A6 82               (fig-forth-auto680):02826                 FCB     $82
19A7 31               (fig-forth-auto680):02827                 FCC     '1'     ; '1+'
19A8 AB               (fig-forth-auto680):02828                 FCB     $AB
19A9 1998             (fig-forth-auto680):02829                 FDB     COLUMS-10
                      (fig-forth-auto680):02830         * Using the model keeps things semantically connected for other processors:
19AB 17B9184516C6     (fig-forth-auto680):02831         ONEP    FDB     DOCOL,ONE,PLUS
19B1 1667             (fig-forth-auto680):02832                 FDB     SEMIS
                      (fig-forth-auto680):02833         ** Greedy alternative:
                      (fig-forth-auto680):02834         * ONEP  FDB     *+NATWID
                      (fig-forth-auto680):02835         *       LDD     ,U
                      (fig-forth-auto680):02836         *       ADDD    ONEV,PCR
                      (fig-forth-auto680):02837         *       STD     ,U
                      (fig-forth-auto680):02838         *       RTS
                      (fig-forth-auto680):02839         * Naive alternative:
                      (fig-forth-auto680):02840         * ONEP  FDB     DOINC
                      (fig-forth-auto680):02841         *       FDB     1
                      (fig-forth-auto680):02842         * Naive alternative:
                      (fig-forth-auto680):02843         * ONEP  FDB     *+NATWID
                      (fig-forth-auto680):02844         *       LDD     ,U
                      (fig-forth-auto680):02845         *       ADDD    #1       ; It's hard to imagine 1+ being other than 1.
                      (fig-forth-auto680):02846         *       STD     ,U
                      (fig-forth-auto680):02847         *       RTS
                      (fig-forth-auto680):02848         *
                      (fig-forth-auto680):02849         * ======>>  84  <<
                      (fig-forth-auto680):02850         * ( n --- n+2 )
19B3 82               (fig-forth-auto680):02851                 FCB     $82
19B4 32               (fig-forth-auto680):02852                 FCC     '2'     ; '2+'
19B5 AB               (fig-forth-auto680):02853                 FCB     $AB
19B6 19A6             (fig-forth-auto680):02854                 FDB     ONEP-5
                      (fig-forth-auto680):02855         * Using the model keeps things semantically connected for other processors:
19B8 17B9184D16C6     (fig-forth-auto680):02856         TWOP    FDB     DOCOL,TWO,PLUS
19BE 1667             (fig-forth-auto680):02857                 FDB     SEMIS
                      (fig-forth-auto680):02858         ** Greedy alternative:
                      (fig-forth-auto680):02859         * TWOP  FDB     *+NATWID
                      (fig-forth-auto680):02860         *       LDD     ,U
                      (fig-forth-auto680):02861         *       ADDD    TWOV,PCR         ; See NAT+ (NATP)
                      (fig-forth-auto680):02862         *       STD     ,U
                      (fig-forth-auto680):02863         *       RTS
                      (fig-forth-auto680):02864         * Naive alternative:
                      (fig-forth-auto680):02865         * TWOP  FDB     DOINC
                      (fig-forth-auto680):02866         *       FDB     2
                      (fig-forth-auto680):02867         * Naive alternative:
                      (fig-forth-auto680):02868         * TWOP  FDB     *+NATWID
                      (fig-forth-auto680):02869         *       LDD     ,U
                      (fig-forth-auto680):02870         *       ADDD    #2       ; See NAT+ (NATP)
                      (fig-forth-auto680):02871         *       STD     ,U
                      (fig-forth-auto680):02872         *       RTS
                      (fig-forth-auto680):02873         *
                      (fig-forth-auto680):02874         * ======>>  85  <<
                      (fig-forth-auto680):02875         * ( --- adr )
                      (fig-forth-auto680):02876         * Get the DICTPT allocation, like a USER constant.  
                      (fig-forth-auto680):02877         * Should check the stack and heap for collision.
19C0 84               (fig-forth-auto680):02878                 FCB     $84
19C1 484552           (fig-forth-auto680):02879                 FCC     'HER'   ; 'HERE'
19C4 C5               (fig-forth-auto680):02880                 FCB     $C5
19C5 19B3             (fig-forth-auto680):02881                 FDB     TWOP-5
19C7 17B918ED1772     (fig-forth-auto680):02882         HERE    FDB     DOCOL,DICTPT,AT
19CD 1667             (fig-forth-auto680):02883                 FDB     SEMIS
                      (fig-forth-auto680):02884         *
                      (fig-forth-auto680):02885         * ======>>  86  <<
                      (fig-forth-auto680):02886         * ( n --- )
                      (fig-forth-auto680):02887         * Increase/decrease heap (add n to DP),
                      (fig-forth-auto680):02888         * Should ERROR check stack/heap.
19CF 85               (fig-forth-auto680):02889                 FCB     $85
19D0 414C4C4F         (fig-forth-auto680):02890                 FCC     'ALLO'  ; 'ALLOT'
19D4 D4               (fig-forth-auto680):02891                 FCB     $D4
19D5 19C0             (fig-forth-auto680):02892                 FDB     HERE-7
19D7 17B918ED1751     (fig-forth-auto680):02893         ALLOT   FDB     DOCOL,DICTPT,PSTORE
19DD 1667             (fig-forth-auto680):02894                 FDB     SEMIS
                      (fig-forth-auto680):02895         *
                      (fig-forth-auto680):02896         * ======>>  87  <<
                      (fig-forth-auto680):02897         * ( n --- )
                      (fig-forth-auto680):02898         * Store word n at DP++,
                      (fig-forth-auto680):02899         * Should ERROR check stack/heap.
19DF 81               (fig-forth-auto680):02900                 FCB     $81     ; , (COMMA)
19E0 AC               (fig-forth-auto680):02901                 FCB     $AC
19E1 19CF             (fig-forth-auto680):02902                 FDB     ALLOT-8
19E3 17B919C7178A17F7 (fig-forth-auto680):02903         COMMA   FDB     DOCOL,HERE,STORE,NATWC,ALLOT
     19D7
19ED 1667             (fig-forth-auto680):02904                 FDB     SEMIS
                      (fig-forth-auto680):02905         * COMMA FDB     DOCOL,HERE,STORE,TWO,ALLOT
                      (fig-forth-auto680):02906         *       FDB     SEMIS
                      (fig-forth-auto680):02907         *
                      (fig-forth-auto680):02908         * ======>>  88  <<
                      (fig-forth-auto680):02909         * ( b --- )
                      (fig-forth-auto680):02910         * Store byte b at DP+,
                      (fig-forth-auto680):02911         * Should ERROR check stack/heap.
19EF 82               (fig-forth-auto680):02912                 FCB     $82
19F0 43               (fig-forth-auto680):02913                 FCC     'C'     ; 'C,'
19F1 AC               (fig-forth-auto680):02914                 FCB     $AC
19F2 19DF             (fig-forth-auto680):02915                 FDB     COMMA-4
19F4 17B919C717981845 (fig-forth-auto680):02916         CCOMM   FDB     DOCOL,HERE,CSTORE,ONE,ALLOT
     19D7
19FE 1667             (fig-forth-auto680):02917                 FDB     SEMIS
                      (fig-forth-auto680):02918         *
                      (fig-forth-auto680):02919         * ======>>  89  <<
                      (fig-forth-auto680):02920         * ( n1 n2 --- n1-n2 )
                      (fig-forth-auto680):02921         * Subtract top two words.
1A00 81               (fig-forth-auto680):02922                 FCB     $81     ; -
1A01 AD               (fig-forth-auto680):02923                 FCB     $AD
1A02 19EF             (fig-forth-auto680):02924                 FDB     CCOMM-5
1A04 1A06             (fig-forth-auto680):02925         SUB     FDB     *+NATWID
1A06 EC42             (fig-forth-auto680):02926                 LDD     NATWID,U        ; #2~6
1A08 A3C1             (fig-forth-auto680):02927                 SUBD    ,U++    ; #2~9
1A0A EDC4             (fig-forth-auto680):02928                 STD     ,U      ; #2~5
1A0C 39               (fig-forth-auto680):02929                 RTS             ; #1~5  = #7~25
                      (fig-forth-auto680):02930         * SUB   FDB     DOCOL,MINUS,PLUS
                      (fig-forth-auto680):02931         *       FDB     SEMIS   ; Costs 6 bytes and lots of cycles.
                      (fig-forth-auto680):02932         *
                      (fig-forth-auto680):02933         * ======>>  90  <<
                      (fig-forth-auto680):02934         * ( n1 n2 --- n1==n2 )
                      (fig-forth-auto680):02935         * Return flag true if n1 and n2 are equal, otherwise false.
1A0D 81               (fig-forth-auto680):02936                 FCB     $81     =
1A0E BD               (fig-forth-auto680):02937                 FCB     $BD
1A0F 1A00             (fig-forth-auto680):02938                 FDB     SUB-4
1A11 17B91A0416A3     (fig-forth-auto680):02939         EQUAL   FDB     DOCOL,SUB,ZEQU
1A17 1667             (fig-forth-auto680):02940                 FDB     SEMIS
                      (fig-forth-auto680):02941         *
                      (fig-forth-auto680):02942         * ======>>  91  <<
                      (fig-forth-auto680):02943         * ( n1 n2 --- n1<n2 )
                      (fig-forth-auto680):02944         * Return flag true if n1 is less than n2, otherwise false.
1A19 81               (fig-forth-auto680):02945                 FCB     $81     <
1A1A BC               (fig-forth-auto680):02946                 FCB     $BC     
1A1B 1A0D             (fig-forth-auto680):02947                 FDB     EQUAL-4
1A1D 1A1F             (fig-forth-auto680):02948         LESS    FDB     *+NATWID
1A1F EC42             (fig-forth-auto680):02949                 LDD     NATWID,U
1A21 A3C1             (fig-forth-auto680):02950                 SUBD    ,U++
1A23 2C06             (fig-forth-auto680):02951                 BGE     FALSE
1A25 CC0001           (fig-forth-auto680):02952         TRUE    LDD     #1
1A28 EDC4             (fig-forth-auto680):02953                 STD     ,U
1A2A 39               (fig-forth-auto680):02954                 RTS
1A2B CC0000           (fig-forth-auto680):02955         FALSE   LDD     #0
1A2E EDC4             (fig-forth-auto680):02956                 STD     ,U
1A30 39               (fig-forth-auto680):02957                 RTS
                      (fig-forth-auto680):02958         *       PULS A  ; 
                      (fig-forth-auto680):02959         *       PULS B  ; 
                      (fig-forth-auto680):02960         *       TFR S,X ; TSX : 
                      (fig-forth-auto680):02961         *       CMPA 0,X
                      (fig-forth-auto680):02962         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02963         *       BGT     LESST
                      (fig-forth-auto680):02964         *       BNE     LESSF
                      (fig-forth-auto680):02965         *       CMPB 1,X        ; Why not sub, sbc, bge?
                      (fig-forth-auto680):02966         *       BHI     LESST
                      (fig-forth-auto680):02967         * LESSF CLRB    ;
                      (fig-forth-auto680):02968         *       BRA     LESSX
                      (fig-forth-auto680):02969         * LESST LDB #1
                      (fig-forth-auto680):02970         * LESSX CLRA    ;
                      (fig-forth-auto680):02971         *       LEAS 1,S        ; 
                      (fig-forth-auto680):02972         *       JMP     PUSHBA
                      (fig-forth-auto680):02973         *
                      (fig-forth-auto680):02974         * ======>>  92  <<
                      (fig-forth-auto680):02975         * ( n1 n2 --- n1>n2 )
                      (fig-forth-auto680):02976         * Return flag true if n1 is greater than n2, false otherwise.
1A31 81               (fig-forth-auto680):02977                 FCB     $81     >
1A32 BE               (fig-forth-auto680):02978                 FCB     $BE
1A33 1A19             (fig-forth-auto680):02979                 FDB     LESS-4
1A35 17B917361A1D     (fig-forth-auto680):02980         GREAT   FDB     DOCOL,SWAP,LESS
1A3B 1667             (fig-forth-auto680):02981                 FDB     SEMIS
                      (fig-forth-auto680):02982         *
                      (fig-forth-auto680):02983         * ======>>  93  <<
                      (fig-forth-auto680):02984         * ( n1 n2 n3 --- n2 n3 n1 )
                      (fig-forth-auto680):02985         * Rotate the top three words on stack,
                      (fig-forth-auto680):02986         * bringing the third word to the top.
1A3D 83               (fig-forth-auto680):02987                 FCB     $83
1A3E 524F             (fig-forth-auto680):02988                 FCC     'RO'    ; 'ROT'
1A40 D4               (fig-forth-auto680):02989                 FCB     $D4
1A41 1A31             (fig-forth-auto680):02990                 FDB     GREAT-4
1A43 1A45             (fig-forth-auto680):02991         ROT     FDB     *+NATWID
1A45 3420             (fig-forth-auto680):02992                 PSHS    Y
1A47 3736             (fig-forth-auto680):02993                 PULU    D,X,Y
1A49 3616             (fig-forth-auto680):02994                 PSHU    D,X
1A4B 3620             (fig-forth-auto680):02995                 PSHU    Y
1A4D 35A0             (fig-forth-auto680):02996                 PULS    Y,PC
                      (fig-forth-auto680):02997         * ROT   FDB     DOCOL,TOR,SWAP,FROMR,SWAP
                      (fig-forth-auto680):02998         *       FDB     SEMIS
                      (fig-forth-auto680):02999         *
                      (fig-forth-auto680):03000         * ======>>  94  <<
                      (fig-forth-auto680):03001         * ( --- )
                      (fig-forth-auto680):03002         * EMIT a SPACE.
1A4F 85               (fig-forth-auto680):03003                 FCB     $85
1A50 53504143         (fig-forth-auto680):03004                 FCC     'SPAC'  ; 'SPACE'
1A54 C5               (fig-forth-auto680):03005                 FCB     $C5
1A55 1A3D             (fig-forth-auto680):03006                 FDB     ROT-6
1A57 17B9185E1542     (fig-forth-auto680):03007         SPACE   FDB     DOCOL,BL,EMIT
1A5D 1667             (fig-forth-auto680):03008                 FDB     SEMIS
                      (fig-forth-auto680):03009         *
                      (fig-forth-auto680):03010         * ======>>  95  <<
                      (fig-forth-auto680):03011         *  ( n0 n1 --- min(n0,n1) )
                      (fig-forth-auto680):03012         * Leave the minimum of the top two integers.
                      (fig-forth-auto680):03013         * Being too greedy here, but, whatever.
1A5F 83               (fig-forth-auto680):03014                 FCB     $83
1A60 4D49             (fig-forth-auto680):03015                 FCC     'MI'    ; 'MIN'
1A62 CE               (fig-forth-auto680):03016                 FCB     $CE
1A63 1A4F             (fig-forth-auto680):03017                 FDB     SPACE-8
1A65 1A67             (fig-forth-auto680):03018         MIN     FDB     *+NATWID
1A67 3706             (fig-forth-auto680):03019                 PULU    D
1A69 10A3C4           (fig-forth-auto680):03020                 CMPD    ,U
1A6C 2F02             (fig-forth-auto680):03021                 BLE     MINX
1A6E EDC4             (fig-forth-auto680):03022                 STD     ,U
1A70 39               (fig-forth-auto680):03023         MINX    RTS     
                      (fig-forth-auto680):03024         * MIN   FDB     DOCOL,OVER,OVER,GREAT,ZBRAN
                      (fig-forth-auto680):03025         *       FDB     MIN2-*-NATWID
                      (fig-forth-auto680):03026         *       FDB     SWAP
                      (fig-forth-auto680):03027         * MIN2  FDB     DROP
                      (fig-forth-auto680):03028         *       FDB     SEMIS
                      (fig-forth-auto680):03029         *
                      (fig-forth-auto680):03030         * ======>>  96  <<
                      (fig-forth-auto680):03031         * ( n0 n1 --- max(n0,n1) )
                      (fig-forth-auto680):03032         * Leave the maximum of the top two integers.
                      (fig-forth-auto680):03033         * Really should leave this as in the model.
1A71 83               (fig-forth-auto680):03034                 FCB     $83
1A72 4D41             (fig-forth-auto680):03035                 FCC     'MA'    ; 'MAX'
1A74 D8               (fig-forth-auto680):03036                 FCB     $D8
1A75 1A5F             (fig-forth-auto680):03037                 FDB     MIN-6
1A77 1A79             (fig-forth-auto680):03038         MAX     FDB     *+NATWID
1A79 3706             (fig-forth-auto680):03039                 PULU    D
1A7B 10A3C4           (fig-forth-auto680):03040                 CMPD    ,U
1A7E 2F02             (fig-forth-auto680):03041                 BLE     MAXX
1A80 EDC4             (fig-forth-auto680):03042                 STD     ,U
1A82 39               (fig-forth-auto680):03043         MAXX    RTS     
                      (fig-forth-auto680):03044         * MAX   FDB     DOCOL,OVER,OVER,LESS,ZBRAN
                      (fig-forth-auto680):03045         *       FDB     MAX2-*-NATWID
                      (fig-forth-auto680):03046         *       FDB     SWAP
                      (fig-forth-auto680):03047         * MAX2  FDB     DROP
                      (fig-forth-auto680):03048         *       FDB     SEMIS
                      (fig-forth-auto680):03049         *
                      (fig-forth-auto680):03050         * ======>>  97  <<
                      (fig-forth-auto680):03051         * ( 0 --- 0 )
                      (fig-forth-auto680):03052         * ( n --- n n )
                      (fig-forth-auto680):03053         * DUP if non-zero.
1A83 84               (fig-forth-auto680):03054                 FCB     $84
1A84 2D4455           (fig-forth-auto680):03055                 FCC     '-DU'   ; '-DUP'
1A87 D0               (fig-forth-auto680):03056                 FCB     $D0
1A88 1A71             (fig-forth-auto680):03057                 FDB     MAX-6
1A8A 1A8C             (fig-forth-auto680):03058         DDUP    FDB     *+NATWID
1A8C ECC4             (fig-forth-auto680):03059                 LDD     ,U
1A8E 2702             (fig-forth-auto680):03060                 BEQ     DDUPX
1A90 3606             (fig-forth-auto680):03061                 PSHU    D
1A92 39               (fig-forth-auto680):03062         DDUPX   RTS
                      (fig-forth-auto680):03063         * DDUP  FDB     DOCOL,DUP,ZBRAN
                      (fig-forth-auto680):03064         *       FDB     DDUP2-*-NATWID
                      (fig-forth-auto680):03065         *       FDB     DUP
                      (fig-forth-auto680):03066         * DDUP2 FDB     SEMIS
                      (fig-forth-auto680):03067         *
                      (fig-forth-auto680):03068         * ######>> screen 39 <<
                      (fig-forth-auto680):03069         * ======>> 98.1 <<
                      (fig-forth-auto680):03070         * Supplemental:
                      (fig-forth-auto680):03071         * ( n<0 --- -1 )
                      (fig-forth-auto680):03072         * ( n>=~ --- 1 )
                      (fig-forth-auto680):03073         * Change top integer to its sign.
1A93 86               (fig-forth-auto680):03074                 FCB     $86
1A94 5349474E55       (fig-forth-auto680):03075                 FCC     'SIGNU' ; 'SIGNUM'
1A99 CD               (fig-forth-auto680):03076                 FCB     $CD
1A9A 1A83             (fig-forth-auto680):03077                 FDB     DDUP-7
1A9C 1A9E             (fig-forth-auto680):03078         SIGNUM  FDB     *+NATWID
1A9E C601             (fig-forth-auto680):03079         SIGNUE  LDB     #1
1AA0 A6C4             (fig-forth-auto680):03080                 LDA     ,U
1AA2 2A01             (fig-forth-auto680):03081                 BPL     SIGNUP
1AA4 50               (fig-forth-auto680):03082                 NEGB
1AA5 1D               (fig-forth-auto680):03083         SIGNUP  SEX     ; Couldn't they have called SignEXtend EXT instead?
1AA6 EDC4             (fig-forth-auto680):03084                 STD     ,U      ; Am I too much of a prude?
1AA8 39               (fig-forth-auto680):03085                 RTS
                      (fig-forth-auto680):03086         * 6800 model version should be something like this:
                      (fig-forth-auto680):03087         *       LDB     #1
                      (fig-forth-auto680):03088         *       CLRA
                      (fig-forth-auto680):03089         *       TSX
                      (fig-forth-auto680):03090         *       TST     ,X
                      (fig-forth-auto680):03091         *       BPL     SIGNUP
                      (fig-forth-auto680):03092         *       NEGB
                      (fig-forth-auto680):03093         *       COMA
                      (fig-forth-auto680):03094         * SIGNUP        JMP     STABX
                      (fig-forth-auto680):03095         *
                      (fig-forth-auto680):03096         * ======>>  98  <<
                      (fig-forth-auto680):03097         * ( adr1 direction --- adr2 )
                      (fig-forth-auto680):03098         * TRAVERSE the symbol name.
                      (fig-forth-auto680):03099         * If direction is 1, find the end.
                      (fig-forth-auto680):03100         * If direction is -1, find the beginning.
1AA9 88               (fig-forth-auto680):03101                 FCB     $88
1AAA 54524156455253   (fig-forth-auto680):03102                 FCC     'TRAVERS'       ; 'TRAVERSE'
1AB1 C5               (fig-forth-auto680):03103                 FCB     $C5
1AB2 1A93             (fig-forth-auto680):03104                 FDB     SIGNUM-9
1AB4 1AB6             (fig-forth-auto680):03105         TRAV    FDB     *+NATWID
1AB6 8DE6             (fig-forth-auto680):03106                 BSR     SIGNUE  ; Convert negative to -, zero or positive to 1.
1AB8 ECC1             (fig-forth-auto680):03107                 LDD     ,U++    ; Still in D, but we have to pop it anyway.
1ABA AEC4             (fig-forth-auto680):03108                 LDX     ,U      ; If D is 1 or -1, so is B.
1ABC 867F             (fig-forth-auto680):03109                 LDA     #$7F    
1ABE 3085             (fig-forth-auto680):03110         TRAVLP  LEAX    B,X     ; Don't look at the one we start at.
1AC0 A184             (fig-forth-auto680):03111                 CMPA    ,X      ; Not sure why we aren't just doing LDA ,X ; BPL.
1AC2 24FA             (fig-forth-auto680):03112                 BCC     TRAVLP
1AC4 AFC4             (fig-forth-auto680):03113         TRAVDN  STX     ,U
1AC6 39               (fig-forth-auto680):03114                 RTS
                      (fig-forth-auto680):03115         * Doing this in 6809 just because it can be done may be getting too greedy.
                      (fig-forth-auto680):03116         * TRAV  FDB     DOCOL,SWAP
                      (fig-forth-auto680):03117         * TRAV2 FDB     OVER,PLUS,LIT8
                      (fig-forth-auto680):03118         *       FCB     $7F
                      (fig-forth-auto680):03119         *       FDB     OVER,CAT,LESS,ZBRAN
                      (fig-forth-auto680):03120         *       FDB     TRAV2-*-NATWID
                      (fig-forth-auto680):03121         *       FDB     SWAP,DROP
                      (fig-forth-auto680):03122         *       FDB     SEMIS
                      (fig-forth-auto680):03123         *
                      (fig-forth-auto680):03124         * ======>>  99  <<
                      (fig-forth-auto680):03125         * ( --- symptr )
                      (fig-forth-auto680):03126         * Fetch CURRENT as a per-USER constant.
1AC7 86               (fig-forth-auto680):03127                 FCB     $86
1AC8 4C41544553       (fig-forth-auto680):03128                 FCC     'LATES' ; 'LATEST'
1ACD D4               (fig-forth-auto680):03129                 FCB     $D4
1ACE 1AA9             (fig-forth-auto680):03130                 FDB     TRAV-11
1AD0 17B9194C17721772 (fig-forth-auto680):03131         LATEST  FDB     DOCOL,CURENT,AT,AT
1AD8 1667             (fig-forth-auto680):03132                 FDB     SEMIS
                      (fig-forth-auto680):03133         * LATEST        FDB     *+NATWID
                      (fig-forth-auto680):03134         * Getting too greedy:
                      (fig-forth-auto680):03135         * Version 1:
                      (fig-forth-auto680):03136         *       TFR     DP,A
                      (fig-forth-auto680):03137         *       CLRB
                      (fig-forth-auto680):03138         *       TFR     D,X
                      (fig-forth-auto680):03139         *       LDD     CURENT+NATWID,PCR
                      (fig-forth-auto680):03140         *       LDX     [D,X]
                      (fig-forth-auto680):03141         *       PSHU    X       ; Leave the address in X.
                      (fig-forth-auto680):03142         *       RTS
                      (fig-forth-auto680):03143         * Version 2:
                      (fig-forth-auto680):03144         *       LEAX    CURENT,PCR
                      (fig-forth-auto680):03145         *       JSR     [,X]
                      (fig-forth-auto680):03146         *       PULU    X
                      (fig-forth-auto680):03147         *       LDX     [,X]
                      (fig-forth-auto680):03148         *       PSHU    X
                      (fig-forth-auto680):03149         *       RTS     
                      (fig-forth-auto680):03150         * Too greedy, too many smantic holes to fall through.
                      (fig-forth-auto680):03151         * If the address at the CFA is made relative, 
                      (fig-forth-auto680):03152         * this is part of the code that would be affected 
                      (fig-forth-auto680):03153         * if it is in native CPU code.
                      (fig-forth-auto680):03154         *
                      (fig-forth-auto680):03155         * ======>>  100  <<
                      (fig-forth-auto680):03156         * Wanted to do these as INCREMENTERs,
                      (fig-forth-auto680):03157         * but I need to stick with the model as much as possible,
                      (fig-forth-auto680):03158         * (mostly, LOL) adding code only to make the model more clear.
                      (fig-forth-auto680):03159         * ( pfa --- lfa )     
                      (fig-forth-auto680):03160         * Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
1ADA 83               (fig-forth-auto680):03161                 FCB     $83
1ADB 4C46             (fig-forth-auto680):03162                 FCC     'LF'    ; 'LFA'
1ADD C1               (fig-forth-auto680):03163                 FCB     $C1
1ADE 1AC7             (fig-forth-auto680):03164                 FDB     LATEST-9
1AE0 17B913A7         (fig-forth-auto680):03165         LFA     FDB     DOCOL,LIT8
                      (fig-forth-auto680):03166         *       FCB     4
1AE4 04               (fig-forth-auto680):03167                 FCB     2*NATWID
1AE5 1A04             (fig-forth-auto680):03168                 FDB     SUB
1AE7 1667             (fig-forth-auto680):03169                 FDB     SEMIS
                      (fig-forth-auto680):03170         *
                      (fig-forth-auto680):03171         * ======>>  101  <<
                      (fig-forth-auto680):03172         * ( pfa --- cfa )    
                      (fig-forth-auto680):03173         * Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
1AE9 83               (fig-forth-auto680):03174                 FCB     $83
1AEA 4346             (fig-forth-auto680):03175                 FCC     'CF'    ; 'CFA'
1AEC C1               (fig-forth-auto680):03176                 FCB     $C1
1AED 1ADA             (fig-forth-auto680):03177                 FDB     LFA-6
                      (fig-forth-auto680):03178         * CFA   FDB     DOCOL,TWO,SUB
1AEF 17B917F71A04     (fig-forth-auto680):03179         CFA     FDB     DOCOL,NATWC,SUB
1AF5 1667             (fig-forth-auto680):03180                 FDB     SEMIS
                      (fig-forth-auto680):03181         *
                      (fig-forth-auto680):03182         * ======>>  102  <<
                      (fig-forth-auto680):03183         * ( pfa --- nfa )     
                      (fig-forth-auto680):03184         * Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
1AF7 83               (fig-forth-auto680):03185                 FCB     $83
1AF8 4E46             (fig-forth-auto680):03186                 FCC     'NF'    ; 'NFA'
1AFA C1               (fig-forth-auto680):03187                 FCB     $C1
1AFB 1AE9             (fig-forth-auto680):03188                 FDB     CFA-6
1AFD 17B913A7         (fig-forth-auto680):03189         NFA     FDB     DOCOL,LIT8
                      (fig-forth-auto680):03190         *       FCB     5
1B01 05               (fig-forth-auto680):03191                 FCB     NATWID*2+1
1B02 1A04184516EF1AB4 (fig-forth-auto680):03192                 FDB     SUB,ONE,MINUS,TRAV
1B0A 1667             (fig-forth-auto680):03193                 FDB     SEMIS
                      (fig-forth-auto680):03194         *
                      (fig-forth-auto680):03195         * ======>>  103  <<
                      (fig-forth-auto680):03196         * ( nfa --- pfa )     
                      (fig-forth-auto680):03197         * Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
1B0C 83               (fig-forth-auto680):03198                 FCB     $83
1B0D 5046             (fig-forth-auto680):03199                 FCC     'PF'    ; 'PFA'
1B0F C1               (fig-forth-auto680):03200                 FCB     $C1
1B10 1AF7             (fig-forth-auto680):03201                 FDB     NFA-6
1B12 17B918451AB413A7 (fig-forth-auto680):03202         PFA     FDB     DOCOL,ONE,TRAV,LIT8
                      (fig-forth-auto680):03203         *       FCB     5
1B1A 05               (fig-forth-auto680):03204                 FCB     NATWID*2+1
1B1B 16C6             (fig-forth-auto680):03205                 FDB     PLUS
1B1D 1667             (fig-forth-auto680):03206                 FDB     SEMIS
                      (fig-forth-auto680):03207         *
                      (fig-forth-auto680):03208         * ######>> screen 40 <<
                      (fig-forth-auto680):03209         * ======>>  104  <<
                      (fig-forth-auto680):03210         * ( --- )
                      (fig-forth-auto680):03211         * Save the parameter stack pointer in CSP for compiler checks.
1B1F 84               (fig-forth-auto680):03212                 FCB     $84
1B20 214353           (fig-forth-auto680):03213                 FCC     '!CS'   ; '!CSP'
1B23 D0               (fig-forth-auto680):03214                 FCB     $D0
1B24 1B0C             (fig-forth-auto680):03215                 FDB     PFA-6
1B26 17B916401981178A (fig-forth-auto680):03216         SCSP    FDB     DOCOL,SPAT,CSP,STORE
1B2E 1667             (fig-forth-auto680):03217                 FDB     SEMIS
                      (fig-forth-auto680):03218         *
                      (fig-forth-auto680):03219         * ======>>  105  <<
                      (fig-forth-auto680):03220         * ( 0 n --- )             ( *** )
                      (fig-forth-auto680):03221         * ( true n --- IN BLK )   ( anything *** nothing )
                      (fig-forth-auto680):03222         * If flag is false, do nothing. 
                      (fig-forth-auto680):03223         * If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR. 
                      (fig-forth-auto680):03224         * Leaves cursor position (IN)
                      (fig-forth-auto680):03225         * and currently loading block number (BLK) on stack, for analysis.
                      (fig-forth-auto680):03226         *
                      (fig-forth-auto680):03227         * This one is too important to be high-level Forth codes.
                      (fig-forth-auto680):03228         * When we have an error, we want to disturb as little as possible.
                      (fig-forth-auto680):03229         * But fixing that cascades through ERROR and MESSAGE 
                      (fig-forth-auto680):03230         * into the disk block system.
                      (fig-forth-auto680):03231         * And we aren't ready for that yet.
1B30 86               (fig-forth-auto680):03232                 FCB     $86
1B31 3F4552524F       (fig-forth-auto680):03233                 FCC     '?ERRO' ; '?ERROR'
1B36 D2               (fig-forth-auto680):03234                 FCB     $D2
1B37 1B1F             (fig-forth-auto680):03235                 FDB     SCSP-7
                      (fig-forth-auto680):03236         * QERR  FDB     *+NATWID
                      (fig-forth-auto680):03237         *       LDD     NATWID,U
                      (fig-forth-auto680):03238         *       BNE     QERROR
                      (fig-forth-auto680):03239         *       LEAU    2*NATWID,U
                      (fig-forth-auto680):03240         *       RTS
                      (fig-forth-auto680):03241         ** this doesn't work anyway: QERROR     LBR     ERROR
1B39 17B917361409     (fig-forth-auto680):03242         QERR    FDB     DOCOL,SWAP,ZBRAN
1B3F 0006             (fig-forth-auto680):03243                 FDB     QERR2-*-NATWID
1B41 1FE713FA         (fig-forth-auto680):03244                 FDB     ERROR,BRAN
1B45 0002             (fig-forth-auto680):03245                 FDB     QERR3-*-NATWID
1B47 172A             (fig-forth-auto680):03246         QERR2   FDB     DROP
1B49 1667             (fig-forth-auto680):03247         QERR3   FDB     SEMIS
                      (fig-forth-auto680):03248         *       
                      (fig-forth-auto680):03249         * ======>>  106  <<
                      (fig-forth-auto680):03250         * STATE is compiling:
                      (fig-forth-auto680):03251         * ( --- )                 ( *** )
                      (fig-forth-auto680):03252         * STATE is compiling:
                      (fig-forth-auto680):03253         * ( --- IN BLK )          ( anything *** nothing )
                      (fig-forth-auto680):03254         * ERROR if not compiling.
1B4B 85               (fig-forth-auto680):03255                 FCB     $85
1B4C 3F434F4D         (fig-forth-auto680):03256                 FCC     '?COM'  ; '?COMP'
1B50 D0               (fig-forth-auto680):03257                 FCB     $D0
1B51 1B30             (fig-forth-auto680):03258                 FDB     QERR-9
1B53 17B91958177216A3 (fig-forth-auto680):03259         QCOMP   FDB     DOCOL,STATE,AT,ZEQU,LIT8
     13A7
1B5D 11               (fig-forth-auto680):03260                 FCB     $11
1B5E 1B39             (fig-forth-auto680):03261                 FDB     QERR
1B60 1667             (fig-forth-auto680):03262                 FDB     SEMIS
                      (fig-forth-auto680):03263         *
                      (fig-forth-auto680):03264         * ======>>  107  <<
                      (fig-forth-auto680):03265         * STATE is executing:
                      (fig-forth-auto680):03266         * ( --- )                 ( *** )
                      (fig-forth-auto680):03267         * STATE is executing:
                      (fig-forth-auto680):03268         * ( --- IN BLK )          ( anything *** nothing )
                      (fig-forth-auto680):03269         * ERROR if not executing.
1B62 85               (fig-forth-auto680):03270                 FCB     $85
1B63 3F455845         (fig-forth-auto680):03271                 FCC     '?EXE'  ; '?EXEC'
1B67 C3               (fig-forth-auto680):03272                 FCB     $C3
1B68 1B4B             (fig-forth-auto680):03273                 FDB     QCOMP-8
1B6A 17B91958177213A7 (fig-forth-auto680):03274         QEXEC   FDB     DOCOL,STATE,AT,LIT8
1B72 12               (fig-forth-auto680):03275                 FCB     $12
1B73 1B39             (fig-forth-auto680):03276                 FDB     QERR
1B75 1667             (fig-forth-auto680):03277                 FDB     SEMIS
                      (fig-forth-auto680):03278         *
                      (fig-forth-auto680):03279         * ======>>  108  <<
                      (fig-forth-auto680):03280         * ( n1 n1 --- )           ( *** )
                      (fig-forth-auto680):03281         * ( n1 n2 --- IN BLK )    ( anything *** nothing )
                      (fig-forth-auto680):03282         * ERROR if top two are unequal. 
                      (fig-forth-auto680):03283         * MESSAGE says compiled conditionals do not match.
1B77 86               (fig-forth-auto680):03284                 FCB     $86
1B78 3F50414952       (fig-forth-auto680):03285                 FCC     '?PAIR' ; '?PAIRS'
1B7D D3               (fig-forth-auto680):03286                 FCB     $D3
1B7E 1B62             (fig-forth-auto680):03287                 FDB     QEXEC-8
1B80 17B91A0413A7     (fig-forth-auto680):03288         QPAIRS  FDB     DOCOL,SUB,LIT8
1B86 13               (fig-forth-auto680):03289                 FCB     $13
1B87 1B39             (fig-forth-auto680):03290                 FDB     QERR
1B89 1667             (fig-forth-auto680):03291                 FDB     SEMIS
                      (fig-forth-auto680):03292         *
                      (fig-forth-auto680):03293         * ======>>  109  <<
                      (fig-forth-auto680):03294         * CSP and parameter stack are balanced (equal):
                      (fig-forth-auto680):03295         * ( --- )                 ( *** )
                      (fig-forth-auto680):03296         * CSP and parameter stack are not balanced (unequal):
                      (fig-forth-auto680):03297         * ( --- IN BLK )          ( anything *** nothing )
                      (fig-forth-auto680):03298         * ERROR if return/control stack is not at same level as last !CSP.
                      (fig-forth-auto680):03299         * Usually indicates that a definition has been left incomplete.
1B8B 84               (fig-forth-auto680):03300                 FCB     $84
1B8C 3F4353           (fig-forth-auto680):03301                 FCC     '?CS'   ; '?CSP'
1B8F D0               (fig-forth-auto680):03302                 FCB     $D0
1B90 1B77             (fig-forth-auto680):03303                 FDB     QPAIRS-9
1B92 17B9164019811772 (fig-forth-auto680):03304         QCSP    FDB     DOCOL,SPAT,CSP,AT,SUB,LIT8
     1A0413A7
1B9E 14               (fig-forth-auto680):03305                 FCB     $14
1B9F 1B39             (fig-forth-auto680):03306                 FDB     QERR
1BA1 1667             (fig-forth-auto680):03307                 FDB     SEMIS
                      (fig-forth-auto680):03308         *
                      (fig-forth-auto680):03309         * ======>>  110  <<
                      (fig-forth-auto680):03310         * Active BLK input:
                      (fig-forth-auto680):03311         * ( --- )         ( *** )
                      (fig-forth-auto680):03312         * No active BLK input:
                      (fig-forth-auto680):03313         * ( --- IN BLK )          ( anything *** nothing )
                      (fig-forth-auto680):03314         * ERROR if not loading, i. e., if BLK is zero.
1BA3 88               (fig-forth-auto680):03315                 FCB     $88
1BA4 3F4C4F4144494E   (fig-forth-auto680):03316                 FCC     '?LOADIN'       ; '?LOADING'
1BAB C7               (fig-forth-auto680):03317                 FCB     $C7
1BAC 1B8B             (fig-forth-auto680):03318                 FDB     QCSP-7
1BAE 17B91906177216A3 (fig-forth-auto680):03319         QLOAD   FDB     DOCOL,BLK,AT,ZEQU,LIT8
     13A7
1BB8 16               (fig-forth-auto680):03320                 FCB     $16
1BB9 1B39             (fig-forth-auto680):03321                 FDB     QERR
1BBB 1667             (fig-forth-auto680):03322                 FDB     SEMIS
                      (fig-forth-auto680):03323         *
                      (fig-forth-auto680):03324         * ######>> screen 41 <<
                      (fig-forth-auto680):03325         * ======>>  111  <<
                      (fig-forth-auto680):03326         * ( --- )
                      (fig-forth-auto680):03327         * Compile an in-line literal value from the instruction stream.
1BBD 87               (fig-forth-auto680):03328                 FCB     $87
1BBE 434F4D50494C     (fig-forth-auto680):03329                 FCC     'COMPIL'        ; 'COMPILE'
1BC4 C5               (fig-forth-auto680):03330                 FCB     $C5
1BC5 1BA3             (fig-forth-auto680):03331                 FDB     QLOAD-11
                      (fig-forth-auto680):03332         * COMPIL        FDB     DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
                      (fig-forth-auto680):03333         * COMPIL        FDB     DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
1BC7 17B91B5316901745 (fig-forth-auto680):03334         COMPIL  FDB     DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
     18021681177219E3
1BD7 1667             (fig-forth-auto680):03335                 FDB     SEMIS
                      (fig-forth-auto680):03336         *
                      (fig-forth-auto680):03337         * ======>>  112  <<
                      (fig-forth-auto680):03338         * ( --- )                                                 P
                      (fig-forth-auto680):03339         * Clear the compile state bit(s) (shift to interpret).
1BD9 C1               (fig-forth-auto680):03340                 FCB     $C1     [       immediate
1BDA DB               (fig-forth-auto680):03341                 FCB     $DB
1BDB 1BBD             (fig-forth-auto680):03342                 FDB     COMPIL-10
1BDD 17B9183D1958178A (fig-forth-auto680):03343         LBRAK   FDB     DOCOL,ZERO,STATE,STORE
1BE5 1667             (fig-forth-auto680):03344                 FDB     SEMIS
                      (fig-forth-auto680):03345         *
                      (fig-forth-auto680):03346         * ======>>  113  <<
                      (fig-forth-auto680):03347         * 
     00C0             (fig-forth-auto680):03348         STCOMP  EQU     $C0
                      (fig-forth-auto680):03349         * ( --- )
                      (fig-forth-auto680):03350         * Set the compile state bit(s) (shift to compile).
1BE7 81               (fig-forth-auto680):03351                 FCB     $81     ]
1BE8 DD               (fig-forth-auto680):03352                 FCB     $DD
1BE9 1BD9             (fig-forth-auto680):03353                 FDB     LBRAK-4
1BEB 17B913A7         (fig-forth-auto680):03354         RBRAK   FDB     DOCOL,LIT8
1BEF C0               (fig-forth-auto680):03355                 FCB     STCOMP
1BF0 1958178A         (fig-forth-auto680):03356                 FDB     STATE,STORE
1BF4 1667             (fig-forth-auto680):03357                 FDB     SEMIS
                      (fig-forth-auto680):03358         *
                      (fig-forth-auto680):03359         * ======>>  114  <<
                      (fig-forth-auto680):03360         * ( --- )
                      (fig-forth-auto680):03361         * Toggle SMUDGE bit of LATEST definition header,
                      (fig-forth-auto680):03362         * to hide it until defined or reveal it after definition.
1BF6 86               (fig-forth-auto680):03363                 FCB     $86
1BF7 534D554447       (fig-forth-auto680):03364                 FCC     'SMUDG' ; 'SMUDGE'
1BFC C5               (fig-forth-auto680):03365                 FCB     $C5
1BFD 1BE7             (fig-forth-auto680):03366                 FDB     RBRAK-4
1BFF 17B91AD013A7     (fig-forth-auto680):03367         SMUDGE  FDB     DOCOL,LATEST,LIT8
1C05 20               (fig-forth-auto680):03368                 FCB     FSMUDG
1C06 1765             (fig-forth-auto680):03369                 FDB     TOGGLE
1C08 1667             (fig-forth-auto680):03370                 FDB     SEMIS
                      (fig-forth-auto680):03371         *
                      (fig-forth-auto680):03372         * ======>>  115  <<
                      (fig-forth-auto680):03373         * ( --- )
                      (fig-forth-auto680):03374         * Set the conversion base to sixteen (b00010000).
1C0A 83               (fig-forth-auto680):03375                 FCB     $83
1C0B 4845             (fig-forth-auto680):03376                 FCC     'HE'    ; 'HEX'
1C0D D8               (fig-forth-auto680):03377                 FCB     $D8
1C0E 1BF6             (fig-forth-auto680):03378                 FDB     SMUDGE-9
1C10 17B9             (fig-forth-auto680):03379         HEX     FDB     DOCOL
1C12 13A7             (fig-forth-auto680):03380                 FDB     LIT8
1C14 10               (fig-forth-auto680):03381                 FCB     16      ; decimal sixteen
1C15 1963178A         (fig-forth-auto680):03382                 FDB     BASE,STORE
1C19 1667             (fig-forth-auto680):03383                 FDB     SEMIS
                      (fig-forth-auto680):03384         *
                      (fig-forth-auto680):03385         * ======>>  116  <<
                      (fig-forth-auto680):03386         * ( --- )
                      (fig-forth-auto680):03387         * Set the conversion base to ten (b00001010).
1C1B 87               (fig-forth-auto680):03388                 FCB     $87
1C1C 444543494D41     (fig-forth-auto680):03389                 FCC     'DECIMA'        ; 'DECIMAL'
1C22 CC               (fig-forth-auto680):03390                 FCB     $CC
1C23 1C0A             (fig-forth-auto680):03391                 FDB     HEX-6
1C25 17B9             (fig-forth-auto680):03392         DEC     FDB     DOCOL
1C27 13A7             (fig-forth-auto680):03393                 FDB     LIT8
1C29 0A               (fig-forth-auto680):03394                 FCB     10      ; decimal ten
1C2A 1963178A         (fig-forth-auto680):03395                 FDB     BASE,STORE
1C2E 1667             (fig-forth-auto680):03396                 FDB     SEMIS
                      (fig-forth-auto680):03397         *
                      (fig-forth-auto680):03398         * ######>> screen 42 <<
                      (fig-forth-auto680):03399         * ======>>  117  <<
                      (fig-forth-auto680):03400         * ( --- )         ( IP *** ) 
                      (fig-forth-auto680):03401         * Pop the saved IP and use it to 
                      (fig-forth-auto680):03402         * compile the latest symbol as a reference to a ;CODE definition;
                      (fig-forth-auto680):03403         * overwrite the code field of the symbol found by LATEST
                      (fig-forth-auto680):03404         * with the address of the low-level characteristic code
                      (fig-forth-auto680):03405         * provided in the defining definition.
                      (fig-forth-auto680):03406         * Look closely at where things return, consider the operation of R> and >R .
                      (fig-forth-auto680):03407         *
                      (fig-forth-auto680):03408         * The machine-level code which follows (;CODE) in the instruction stream
                      (fig-forth-auto680):03409         * is not executed by the defining symbol,
                      (fig-forth-auto680):03410         * but becomes the characteristic of the defined symbol. 
                      (fig-forth-auto680):03411         * This is the usual way to generate the characteristics of VARIABLEs,
                      (fig-forth-auto680):03412         * CONSTANTs, COLON definitions, etc., when FORTH compiles itself. 
                      (fig-forth-auto680):03413         *
                      (fig-forth-auto680):03414         * Finally, note that, if code shifts from low level back to high 
                      (fig-forth-auto680):03415         * (native CPU machine code calling into a list of FORTH codes),
                      (fig-forth-auto680):03416         * the low level code can't just call a high-level definition. 
                      (fig-forth-auto680):03417         * Leaf definitions can directly call other leaf definitions, 
                      (fig-forth-auto680):03418         * but not non-leafs.
                      (fig-forth-auto680):03419         * It will need an anonymous list, probably embedded in the low-level code,
                      (fig-forth-auto680):03420         * and Y and X will have to be set appropriately before entering the list.
1C30 87               (fig-forth-auto680):03421                 FCB     $87
1C31 283B434F4445     (fig-forth-auto680):03422                 FCC     '(;CODE'        ; '(;CODE)'
1C37 A9               (fig-forth-auto680):03423                 FCB     $A9
1C38 1C1B             (fig-forth-auto680):03424                 FDB     DEC-10
                      (fig-forth-auto680):03425         * PSCODE        FDB     DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
1C3A 17B91690         (fig-forth-auto680):03426         PSCODE  FDB     DOCOL,FROMR     ; Y/IP is post-inc, needs no adjustment.
1C3E 1AD01B121AEF178A (fig-forth-auto680):03427                 FDB     LATEST,PFA,CFA,STORE
1C46 1667             (fig-forth-auto680):03428                 FDB     SEMIS
                      (fig-forth-auto680):03429         *
                      (fig-forth-auto680):03430         * ======>>  118  <<
                      (fig-forth-auto680):03431         * ( --- )                                                 P
                      (fig-forth-auto680):03432         * ?CSP to see if there are loose ends in the defining definition
                      (fig-forth-auto680):03433         * before shifting to the assembler,
                      (fig-forth-auto680):03434         * compile (;CODE) in the defining definition's instruction stream,
                      (fig-forth-auto680):03435         * shift to interpreting,
                      (fig-forth-auto680):03436         * make the ASSEMBLER vocabulary current,
                      (fig-forth-auto680):03437         * and !CSP to mark the stack
                      (fig-forth-auto680):03438         * in preparation for assembling low-level code.
                      (fig-forth-auto680):03439         * Note that ;CODE, unlike DOES>, is IMMEDIATE,
                      (fig-forth-auto680):03440         * and compiles (;CODE),
                      (fig-forth-auto680):03441         * which will do the actual work of changing
                      (fig-forth-auto680):03442         * the LATEST definition's characteristic when the defining word runs.
                      (fig-forth-auto680):03443         * Assembly is done by the interpreter, rather than the compiler.
                      (fig-forth-auto680):03444         * I could have avoided the anomalous three-byte code fields by
                      (fig-forth-auto680):03445         *
                      (fig-forth-auto680):03446         * Note that the ASSEMBLER is not part of the model (at this time).
                      (fig-forth-auto680):03447         * That means that, until the assembler is ready, 
                      (fig-forth-auto680):03448         * if you want to define low-level words,
                      (fig-forth-auto680):03449         * you have to poke (comma) in hand-assembled stuff.
                      (fig-forth-auto680):03450         *
1C48 C5               (fig-forth-auto680):03451                 FCB     $C5     immediate
1C49 3B434F44         (fig-forth-auto680):03452                 FCC     ';COD'  ; ';CODE'
1C4D C5               (fig-forth-auto680):03453                 FCB     $C5
1C4E 1C30             (fig-forth-auto680):03454                 FDB     PSCODE-10
1C50 17B91B921BC71C3A (fig-forth-auto680):03455         SEMIC   FDB     DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
     1BFF1BDD1D5B
1C5E 1667             (fig-forth-auto680):03456                 FDB     SEMIS
                      (fig-forth-auto680):03457         * note: "QSTACK" will be replaced by "ASSEMBLER" later
                      (fig-forth-auto680):03458         *
                      (fig-forth-auto680):03459         * ######>> screen 43 <<
                      (fig-forth-auto680):03460         * ======>>  119  <<
                      (fig-forth-auto680):03461         * ( --- )                                                 C
                      (fig-forth-auto680):03462         * Make the word currently being defined
                      (fig-forth-auto680):03463         * build a header for DOES> definitions. 
                      (fig-forth-auto680):03464         * Actually just compiles a CONSTANT zero
                      (fig-forth-auto680):03465         * which can be overwritten later by DOES>.
                      (fig-forth-auto680):03466         * Since the fig models were established, this technique has been deprecated.
                      (fig-forth-auto680):03467         *
                      (fig-forth-auto680):03468         * Note that <BUILDS is not IMMEDIATE,
                      (fig-forth-auto680):03469         * and therefore executes during a definition's run-time,
                      (fig-forth-auto680):03470         * rather than its compile-time. 
                      (fig-forth-auto680):03471         * It is not intended to be used directly,
                      (fig-forth-auto680):03472         * but rather so that one definition word can build another. 
                      (fig-forth-auto680):03473         * Also, note that nothing particularly special happens
                      (fig-forth-auto680):03474         * in the defining definition until DOES> executes. 
                      (fig-forth-auto680):03475         * The name <BUILDS is intended to be a reminder of what is about to occur.
                      (fig-forth-auto680):03476         *
                      (fig-forth-auto680):03477         * <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
1C60 87               (fig-forth-auto680):03478                 FCB     $87
1C61 3C4255494C44     (fig-forth-auto680):03479                 FCC     '<BUILD'        ; '<BUILDS'
1C67 D3               (fig-forth-auto680):03480                 FCB     $D3
1C68 1C48             (fig-forth-auto680):03481                 FDB     SEMIC-8
1C6A 17B9183D17DF     (fig-forth-auto680):03482         BUILDS  FDB     DOCOL,ZERO,CON
1C70 1667             (fig-forth-auto680):03483                 FDB     SEMIS
                      (fig-forth-auto680):03484         *
                      (fig-forth-auto680):03485         * ======>>  120  <<
                      (fig-forth-auto680):03486         * ( --- )         ( IP *** )                              C
                      (fig-forth-auto680):03487         * Define run-time behavior of definitions compiled/defined
                      (fig-forth-auto680):03488         * by a high-level defining definition --
                      (fig-forth-auto680):03489         * the FORTH equivalent of a compiler-compiler. 
                      (fig-forth-auto680):03490         * DOES> assumes that the LATEST symbol table entry
                      (fig-forth-auto680):03491         * has at least one word of parameter field,
                      (fig-forth-auto680):03492         * which <BUILDS provides. 
                      (fig-forth-auto680):03493         * Note that DOES> is also not IMMEDIATE. 
                      (fig-forth-auto680):03494         *
                      (fig-forth-auto680):03495         * When the defining word containing DOES> executes the DOES> icode,
                      (fig-forth-auto680):03496         * it overwrites the LATEST symbol's CFA with jsr <XDOES,
                      (fig-forth-auto680):03497         * overwrites the first word of that symbol's parameter field with its own IP,
                      (fig-forth-auto680):03498         * and pops the previous IP from the return stack.
                      (fig-forth-auto680):03499         * The icodes which follow DOES> in the stream
                      (fig-forth-auto680):03500         * do not execute at the defining word's run-time.
                      (fig-forth-auto680):03501         *
                      (fig-forth-auto680):03502         * Examining XDOES in the virtual machine shows
                      (fig-forth-auto680):03503         * that the defined word will execute those icodes
                      (fig-forth-auto680):03504         * which follow DOES> at its own run-time. 
                      (fig-forth-auto680):03505         *
                      (fig-forth-auto680):03506         * The advantage of this kind of behaviour,
                      (fig-forth-auto680):03507         * which you will also note in ;CODE,
                      (fig-forth-auto680):03508         * is that the defined word can contain
                      (fig-forth-auto680):03509         * both operations and data to be operated on. 
                      (fig-forth-auto680):03510         * This is how FORTH data objects define their own behavior. 
                      (fig-forth-auto680):03511         *
                      (fig-forth-auto680):03512         * Finally, note that the effective parameter field for DOES> definitions
                      (fig-forth-auto680):03513         * starts two NATWID words after the CFA, instead of just one
                      (fig-forth-auto680):03514         * (four bytes instead of two in a sixteen-bit addressing Forth).
                      (fig-forth-auto680):03515         *
                      (fig-forth-auto680):03516         * VOCABULARYs will use this. See definition of word FORTH.
1C72 85               (fig-forth-auto680):03517                 FCB     $85
1C73 444F4553         (fig-forth-auto680):03518                 FCC     'DOES'  ; 'DOES>'
1C77 BE               (fig-forth-auto680):03519                 FCB     $BE
1C78 1C60             (fig-forth-auto680):03520                 FDB     BUILDS-10
                      (fig-forth-auto680):03521         * DOES  FDB     DOCOL,FROMR,TWOP,LATEST,PFA,STORE
1C7A 17B91690         (fig-forth-auto680):03522         DOES    FDB     DOCOL,FROMR     ; Y/IP is post-inc, needs no adjustment.
1C7E 1AD01B12178A     (fig-forth-auto680):03523                 FDB     LATEST,PFA,STORE
1C84 1C3A             (fig-forth-auto680):03524                 FDB     PSCODE
                      (fig-forth-auto680):03525         *
                      (fig-forth-auto680):03526         * ( --- PFA+NATWID )     ( *** IP )
                      (fig-forth-auto680):03527         * Characteristic of a DOES> defined word. 
                      (fig-forth-auto680):03528         * The characteristics of DOES> definitions are written in high-level
                      (fig-forth-auto680):03529         * Forth codes rather than native CPU machine level code.
                      (fig-forth-auto680):03530         * The first parameter word points to the high-level characteristic. 
                      (fig-forth-auto680):03531         * This routine's job is to push the IP,
                      (fig-forth-auto680):03532         * load the high level characteristic pointer in IP,
                      (fig-forth-auto680):03533         * and leave the address following the characteristic pointer on the stack
                      (fig-forth-auto680):03534         * so the parameter field can be accessed.
1C86 ECE4             (fig-forth-auto680):03535         DODOES  LDD     ,S      ; Keep the return address.
1C88 10AFE4           (fig-forth-auto680):03536                 STY     ,S      ; Save/nest the current IP on the return stack.
1C8B 10AE02           (fig-forth-auto680):03537                 LDY     NATWID,X        ; First parameter is new IP.
1C8E 3004             (fig-forth-auto680):03538                 LEAX    2*NATWID,X      ; Address of second parameter.
1C90 3610             (fig-forth-auto680):03539                 PSHU    X
1C92 1F05             (fig-forth-auto680):03540                 TFR     D,PC    ; Synthetic return.
                      (fig-forth-auto680):03541         *
                      (fig-forth-auto680):03542         * From the 6800 model:
                      (fig-forth-auto680):03543         * DODOES        LDA IP
                      (fig-forth-auto680):03544         *       LDB IP+1
                      (fig-forth-auto680):03545         *       LDX     RP      make room on return stack
                      (fig-forth-auto680):03546         *       LEAX -1,X       ; 
                      (fig-forth-auto680):03547         *       LEAX -1,X       ; 
                      (fig-forth-auto680):03548         *       STX     RP
                      (fig-forth-auto680):03549         *       STA 2,X push return address
                      (fig-forth-auto680):03550         *       STB 3,X
                      (fig-forth-auto680):03551         *       LDX     W       get addr of pointer to run-time code
                      (fig-forth-auto680):03552         *       LEAX 1,X        ; 
                      (fig-forth-auto680):03553         *       LEAX 1,X        ; 
                      (fig-forth-auto680):03554         *       STX     N       stash it in scratch area
                      (fig-forth-auto680):03555         *       LDX     0,X     get new IP
                      (fig-forth-auto680):03556         *       STX     IP
                      (fig-forth-auto680):03557         *       CLRA    ;               get address of parameter
                      (fig-forth-auto680):03558         *       LDB #2
                      (fig-forth-auto680):03559         *       ADDB N+1
                      (fig-forth-auto680):03560         *       ADCA N
                      (fig-forth-auto680):03561         *       PSHS B  ; and push it on data stack
                      (fig-forth-auto680):03562         *       PSHS A  ; 
                      (fig-forth-auto680):03563         *       JMP     NEXT2
                      (fig-forth-auto680):03564         *
                      (fig-forth-auto680):03565         * ######>> screen 44 <<
                      (fig-forth-auto680):03566         * ======>>  121  <<
                      (fig-forth-auto680):03567         * ( strptr --- strptr+1 count )
                      (fig-forth-auto680):03568         * Convert counted string to string and count. 
                      (fig-forth-auto680):03569         * (Fetch the byte at strptr, post-increment.)
1C94 85               (fig-forth-auto680):03570                 FCB     $85
1C95 434F554E         (fig-forth-auto680):03571                 FCC     'COUN'  ; 'COUNT'
1C99 D4               (fig-forth-auto680):03572                 FCB     $D4
1C9A 1C72             (fig-forth-auto680):03573                 FDB     DOES-8
1C9C 17B9174519AB1736 (fig-forth-auto680):03574         COUNT   FDB     DOCOL,DUP,ONEP,SWAP,CAT
     177E
1CA6 1667             (fig-forth-auto680):03575                 FDB     SEMIS
                      (fig-forth-auto680):03576         *
                      (fig-forth-auto680):03577         * ======>>  122  <<
                      (fig-forth-auto680):03578         * ( strptr count --- )
                      (fig-forth-auto680):03579         * EMIT count characters at strptr.
1CA8 84               (fig-forth-auto680):03580                 FCB     $84
1CA9 545950           (fig-forth-auto680):03581                 FCC     'TYP'   ; 'TYPE'
1CAC C5               (fig-forth-auto680):03582                 FCB     $C5
1CAD 1C94             (fig-forth-auto680):03583                 FDB     COUNT-8
1CAF 17B91A8A1409     (fig-forth-auto680):03584         TYPE    FDB     DOCOL,DDUP,ZBRAN
1CB5 0016             (fig-forth-auto680):03585                 FDB     TYPE3-*-NATWID
1CB7 171C16C617361453 (fig-forth-auto680):03586                 FDB     OVER,PLUS,SWAP,XDO
1CBF 1465177E1542141D (fig-forth-auto680):03587         TYPE2   FDB     I,CAT,EMIT,XLOOP
1CC7 FFF6             (fig-forth-auto680):03588                 FDB     TYPE2-*-NATWID
1CC9 13FA             (fig-forth-auto680):03589                 FDB     BRAN
1CCB 0002             (fig-forth-auto680):03590                 FDB     TYPE4-*-NATWID
1CCD 172A             (fig-forth-auto680):03591         TYPE3   FDB     DROP
1CCF 1667             (fig-forth-auto680):03592         TYPE4   FDB     SEMIS
                      (fig-forth-auto680):03593         *
                      (fig-forth-auto680):03594         * ======>>  123  <<
                      (fig-forth-auto680):03595         * ( strptr count1 --- strptr count2 )
                      (fig-forth-auto680):03596         * Supress trailing blanks (subtract count of trailing blanks from strptr).
1CD1 89               (fig-forth-auto680):03597                 FCB     $89
1CD2 2D545241494C494E (fig-forth-auto680):03598                 FCC     '-TRAILIN'      ; '-TRAILING'
1CDA C7               (fig-forth-auto680):03599                 FCB     $C7
1CDB 1CA8             (fig-forth-auto680):03600                 FDB     TYPE-7
1CDD 17B91745183D1453 (fig-forth-auto680):03601         DTRAIL  FDB     DOCOL,DUP,ZERO,XDO
1CE5 171C171C16C61845 (fig-forth-auto680):03602         DTRAL2  FDB     OVER,OVER,PLUS,ONE,SUB,CAT,BL
     1A04177E185E
1CF3 1A041409         (fig-forth-auto680):03603                 FDB     SUB,ZBRAN
1CF7 0006             (fig-forth-auto680):03604                 FDB     DTRAL3-*-NATWID
1CF9 167513FA         (fig-forth-auto680):03605                 FDB     LEAVE,BRAN
1CFD 0004             (fig-forth-auto680):03606                 FDB     DTRAL4-*-NATWID
1CFF 18451A04         (fig-forth-auto680):03607         DTRAL3  FDB     ONE,SUB
1D03 141D             (fig-forth-auto680):03608         DTRAL4  FDB     XLOOP
1D05 FFDE             (fig-forth-auto680):03609                 FDB     DTRAL2-*-NATWID
1D07 1667             (fig-forth-auto680):03610                 FDB     SEMIS
                      (fig-forth-auto680):03611         *
                      (fig-forth-auto680):03612         * ======>>  124  <<
                      (fig-forth-auto680):03613         * ( --- ) 
                      (fig-forth-auto680):03614         * TYPE counted string out of instruction stream (updating IP).
1D09 84               (fig-forth-auto680):03615                 FCB     $84
1D0A 282E22           (fig-forth-auto680):03616                 FCC     '(."'   ; '(.")'
1D0D A9               (fig-forth-auto680):03617                 FCB     $A9
1D0E 1CD1             (fig-forth-auto680):03618                 FDB     DTRAIL-12
                      (fig-forth-auto680):03619         * PDOTQ FDB     DOCOL,R,TWOP,COUNT,DUP,ONEP
                      (fig-forth-auto680):03620         * PDOTQ FDB     DOCOL,R,NATP,COUNT,DUP,ONEP
1D10 17B9169C1C9C1745 (fig-forth-auto680):03621         PDOTQ   FDB     DOCOL,R,COUNT,DUP,ONEP
     19AB
1D1A 169016C616811CAF (fig-forth-auto680):03622                 FDB     FROMR,PLUS,TOR,TYPE
1D22 1667             (fig-forth-auto680):03623                 FDB     SEMIS
                      (fig-forth-auto680):03624         *
                      (fig-forth-auto680):03625         * ======>>  125  <<
                      (fig-forth-auto680):03626         * ( --- )                                                 P
                      (fig-forth-auto680):03627         * { ." something-to-be-printed " } typical input
                      (fig-forth-auto680):03628         * Use WORD to parse to trailing quote;
                      (fig-forth-auto680):03629         * if compiling, compile XDOTQ and string parsed,
                      (fig-forth-auto680):03630         * otherwise, TYPE string.
1D24 C2               (fig-forth-auto680):03631                 FCB     $C2     immediate
1D25 2E               (fig-forth-auto680):03632                 FCC     '.'     ; '."'
1D26 A2               (fig-forth-auto680):03633                 FCB     $A2
1D27 1D09             (fig-forth-auto680):03634                 FDB     PDOTQ-7
1D29 17B9             (fig-forth-auto680):03635         DOTQ    FDB     DOCOL
1D2B 13A7             (fig-forth-auto680):03636                 FDB     LIT8
1D2D 22               (fig-forth-auto680):03637                 FCB     $22     ascii quote
1D2E 195817721409     (fig-forth-auto680):03638                 FDB     STATE,AT,ZBRAN
1D34 0012             (fig-forth-auto680):03639                 FDB     DOTQ1-*-NATWID
1D36 1BC71D101EBC     (fig-forth-auto680):03640                 FDB     COMPIL,PDOTQ,WORD
1D3C 19C7177E19AB19D7 (fig-forth-auto680):03641                 FDB     HERE,CAT,ONEP,ALLOT,BRAN
     13FA
1D46 0008             (fig-forth-auto680):03642                 FDB     DOTQ2-*-NATWID
1D48 1EBC19C71C9C1CAF (fig-forth-auto680):03643         DOTQ1   FDB     WORD,HERE,COUNT,TYPE
1D50 1667             (fig-forth-auto680):03644         DOTQ2   FDB     SEMIS
                      (fig-forth-auto680):03645         *
                      (fig-forth-auto680):03646         * ######>> screen 45 <<
                      (fig-forth-auto680):03647         * ======>>  126  <<== MACHINE DEPENDENT
                      (fig-forth-auto680):03648         * ( --- )                 ( *** )
                      (fig-forth-auto680):03649         * ( --- IN BLK )          ( anything *** nothing )
                      (fig-forth-auto680):03650         * ERROR if parameter stack out of bounds.
                      (fig-forth-auto680):03651         * 
                      (fig-forth-auto680):03652         * But checking whether the stack is in bounds or not
                      (fig-forth-auto680):03653         * really should not use the stack.
                      (fig-forth-auto680):03654         * And there really should be a ?RSTACK, as well.
1D52 86               (fig-forth-auto680):03655                 FCB     $86
1D53 3F53544143       (fig-forth-auto680):03656                 FCC     '?STAC' ; '?STACK'
1D58 CB               (fig-forth-auto680):03657                 FCB     $CB
1D59 1D24             (fig-forth-auto680):03658                 FDB     DOTQ-5
1D5B 17B913A7         (fig-forth-auto680):03659         QSTACK  FDB     DOCOL,LIT8
                      (fig-forth-auto680):03660         *       FCB     $12
1D5F 12               (fig-forth-auto680):03661                 FCB     SINIT-ORIG
                      (fig-forth-auto680):03662         * But why use that instead of XSPZER (S0)?
                      (fig-forth-auto680):03663         * Multi-user or multi-tasking would not want that.
                      (fig-forth-auto680):03664         *       CMPU    <XSPZER 
                      (fig-forth-auto680):03665         *       FDB     PORIG,AT,TWO,SUB,SPAT,LESS,ONE
1D60 189C177216401A1D (fig-forth-auto680):03666                 FDB     PORIG,AT,SPAT,LESS,ONE  ; Not post-decrement push.
     1845
1D6A 1B39             (fig-forth-auto680):03667                 FDB     QERR
                      (fig-forth-auto680):03668         * prints 'empty stack'
                      (fig-forth-auto680):03669         *
1D6C 1640             (fig-forth-auto680):03670         QSTAC2  FDB     SPAT
                      (fig-forth-auto680):03671         * Here, we compare with a value at least 128
                      (fig-forth-auto680):03672         * higher than dict. ptr. (DICTPT)
1D6E 19C713A7         (fig-forth-auto680):03673                 FDB     HERE,LIT8
1D72 80               (fig-forth-auto680):03674                 FCB     $80     ; This is a rough check anyway, leave it as is.
1D73 16C61A1D1409     (fig-forth-auto680):03675                 FDB     PLUS,LESS,ZBRAN
1D79 0004             (fig-forth-auto680):03676                 FDB     QSTAC3-*-NATWID
1D7B 184D             (fig-forth-auto680):03677                 FDB     TWO     ; NOT the NATWID constant!
1D7D 1B39             (fig-forth-auto680):03678                 FDB     QERR
                      (fig-forth-auto680):03679         * prints 'full stack'
                      (fig-forth-auto680):03680         *
1D7F 1667             (fig-forth-auto680):03681         QSTAC3  FDB     SEMIS
                      (fig-forth-auto680):03682         *
                      (fig-forth-auto680):03683         * ======>>  127  <<     this word's function
                      (fig-forth-auto680):03684         *           is done by ?STACK in this version
                      (fig-forth-auto680):03685         *       FCB     $85
                      (fig-forth-auto680):03686         *       FCC     4,?FREE
                      (fig-forth-auto680):03687         *       FCB     $C5
                      (fig-forth-auto680):03688         *       FDB     QSTACK-9
                      (fig-forth-auto680):03689         *QFREE  FDB     DOCOL,SPAT,HERE,LIT8
                      (fig-forth-auto680):03690         *       FCB     $80
                      (fig-forth-auto680):03691         *       FDB     PLUS,LESS,TWO,QERR,SEMIS        ; This TWO is not NATWID!
                      (fig-forth-auto680):03692         *
                      (fig-forth-auto680):03693         * ######>> screen 46 <<
                      (fig-forth-auto680):03694         * ======>>  128  <<
                      (fig-forth-auto680):03695         * ( buffer n --- )
                      (fig-forth-auto680):03696         * ***** Check that this is how it works here:
                      (fig-forth-auto680):03697         * Get up to n-1 characters from the keyboard,
                      (fig-forth-auto680):03698         * storing at buffer and echoing, with backspace editing,
                      (fig-forth-auto680):03699         * quitting when a CR is read.
                      (fig-forth-auto680):03700         * Terminate it with a NUL.
1D81 86               (fig-forth-auto680):03701                 FCB     $86
1D82 4558504543       (fig-forth-auto680):03702                 FCC     'EXPEC' ; 'EXPECT'
1D87 D4               (fig-forth-auto680):03703                 FCB     $D4
1D88 1D52             (fig-forth-auto680):03704                 FDB     QSTACK-9
1D8A 17B9171C16C6171C (fig-forth-auto680):03705         EXPECT  FDB     DOCOL,OVER,PLUS,OVER,XDO        ; brace the buffer area
     1453
                      (fig-forth-auto680):03706         * EXPEC2        FDB     KEY,DUP,LIT8
1D94 1556             (fig-forth-auto680):03707         EXPEC2  FDB     KEY
1D96 1399001C13B9     (fig-forth-auto680):03708                 FDB     LIT,$1C,SHOTOS  ; DBG
1D9C 174513A7         (fig-forth-auto680):03709                 FDB     DUP,LIT8
1DA0 0E               (fig-forth-auto680):03710                 FCB     BACKSP-ORIG
1DA1 189C17721A111409 (fig-forth-auto680):03711                 FDB     PORIG,AT,EQUAL,ZBRAN    ; check for backspacing 
1DA9 001D             (fig-forth-auto680):03712                 FDB     EXPEC3-*-NATWID
1DAB 172A13A7         (fig-forth-auto680):03713                 FDB     DROP,LIT8
1DAF 08               (fig-forth-auto680):03714                 FCB     8       ( backspace character to emit )
1DB0 171C14651A111745 (fig-forth-auto680):03715                 FDB     OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS     ; back I up TWO characters 
     1690184D1A0416C6
1DC0 16811A0413FA     (fig-forth-auto680):03716                 FDB     TOR,SUB,BRAN
1DC6 0025             (fig-forth-auto680):03717                 FDB     EXPEC6-*-NATWID
1DC8 174513A7         (fig-forth-auto680):03718         EXPEC3  FDB     DUP,LIT8
1DCC 0D               (fig-forth-auto680):03719                 FCB     $D      ( carriage return )
1DCD 1A111409         (fig-forth-auto680):03720                 FDB     EQUAL,ZBRAN
1DD1 000C             (fig-forth-auto680):03721                 FDB     EXPEC4-*-NATWID
1DD3 1675172A185E183D (fig-forth-auto680):03722                 FDB     LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
     13FA
1DDD 0002             (fig-forth-auto680):03723                 FDB     EXPEC5-*-NATWID
1DDF 1745             (fig-forth-auto680):03724         EXPEC4  FDB     DUP
1DE1 14651798183D1465 (fig-forth-auto680):03725         EXPEC5  FDB     I,CSTORE,ZERO,I,ONEP,STORE
     19AB178A
1DED 1542141D         (fig-forth-auto680):03726         EXPEC6  FDB     EMIT,XLOOP
1DF1 FFA1             (fig-forth-auto680):03727                 FDB     EXPEC2-*-NATWID
1DF3 172A             (fig-forth-auto680):03728                 FDB     DROP
1DF5 1667             (fig-forth-auto680):03729                 FDB     SEMIS
                      (fig-forth-auto680):03730         *
                      (fig-forth-auto680):03731         * ======>>  129  <<
                      (fig-forth-auto680):03732         * ( --- )
                      (fig-forth-auto680):03733         * EXPECT 128 (TWID) characters to TIB.
1DF7 85               (fig-forth-auto680):03734                 FCB     $85
1DF8 51554552         (fig-forth-auto680):03735                 FCC     'QUER'  ; 'QUERY'
1DFC D9               (fig-forth-auto680):03736                 FCB     $D9
1DFD 1D81             (fig-forth-auto680):03737                 FDB     EXPECT-9
1DFF 17B918BE177219A2 (fig-forth-auto680):03738         QUERY   FDB     DOCOL,TIB,AT,COLUMS
1E07 17721D8A183D190F (fig-forth-auto680):03739                 FDB     AT,EXPECT,ZERO,IN,STORE
     178A
1E11 1667             (fig-forth-auto680):03740                 FDB     SEMIS
                      (fig-forth-auto680):03741         *
                      (fig-forth-auto680):03742         * ======>>  130  <<
                      (fig-forth-auto680):03743         * ( --- )                                                 P
                      (fig-forth-auto680):03744         * End interpretation of a line or screen, and/or prepare for a new block. 
                      (fig-forth-auto680):03745         * Note that the name of this definition is an empty string,
                      (fig-forth-auto680):03746         * so it matches on the terminating NUL in the terminal or block buffer.
1E13 C1               (fig-forth-auto680):03747                 FCB     $C1     immediate       < carriage return >
1E14 80               (fig-forth-auto680):03748                 FCB     $80
1E15 1DF7             (fig-forth-auto680):03749                 FDB     QUERY-8
1E17 17B9190617721409 (fig-forth-auto680):03750         NULL    FDB     DOCOL,BLK,AT,ZBRAN
1E1F 0024             (fig-forth-auto680):03751                 FDB     NULL2-*-NATWID
1E21 184519061751     (fig-forth-auto680):03752                 FDB     ONE,BLK,PSTORE
1E27 183D190F178A1906 (fig-forth-auto680):03753                 FDB     ZERO,IN,STORE,BLK,AT,BSCR,MOD
     1772188E2335
1E35 16A3             (fig-forth-auto680):03754                 FDB     ZEQU
                      (fig-forth-auto680):03755         *     check for end of screen
1E37 1409             (fig-forth-auto680):03756                 FDB     ZBRAN
1E39 0006             (fig-forth-auto680):03757                 FDB     NULL1-*-NATWID
1E3B 1B6A1690172A     (fig-forth-auto680):03758                 FDB     QEXEC,FROMR,DROP
1E41 13FA             (fig-forth-auto680):03759         NULL1   FDB     BRAN
1E43 0004             (fig-forth-auto680):03760                 FDB     NULL3-*-NATWID
1E45 1690172A         (fig-forth-auto680):03761         NULL2   FDB     FROMR,DROP
1E49 1667             (fig-forth-auto680):03762         NULL3   FDB     SEMIS
                      (fig-forth-auto680):03763         *
                      (fig-forth-auto680):03764         * ######>> screen 47 <<
                      (fig-forth-auto680):03765         * ======>>  133  <<
                      (fig-forth-auto680):03766         * ( adr n b --- )
                      (fig-forth-auto680):03767         * Fill n bytes at adr with b.
1E4B 84               (fig-forth-auto680):03768                 FCB     $84
1E4C 46494C           (fig-forth-auto680):03769                 FCC     'FIL'   ; 'FILL'
1E4F CC               (fig-forth-auto680):03770                 FCB     $CC
1E50 1E13             (fig-forth-auto680):03771                 FDB     NULL-4
1E52 17B917361681171C (fig-forth-auto680):03772         FILL    FDB     DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
     1798174519AB
1E60 169018451A041584 (fig-forth-auto680):03773                 FDB     FROMR,ONE,SUB,CMOVE
1E68 1667             (fig-forth-auto680):03774                 FDB     SEMIS
                      (fig-forth-auto680):03775         *
                      (fig-forth-auto680):03776         * ======>>  134  <<
                      (fig-forth-auto680):03777         * ( adr n --- )
                      (fig-forth-auto680):03778         * Fill n bytes with 0.
1E6A 85               (fig-forth-auto680):03779                 FCB     $85
1E6B 45524153         (fig-forth-auto680):03780                 FCC     'ERAS'  ; 'ERASE'
1E6F C5               (fig-forth-auto680):03781                 FCB     $C5
1E70 1E4B             (fig-forth-auto680):03782                 FDB     FILL-7
1E72 17B9183D1E52     (fig-forth-auto680):03783         ERASE   FDB     DOCOL,ZERO,FILL
1E78 1667             (fig-forth-auto680):03784                 FDB     SEMIS
                      (fig-forth-auto680):03785         *
                      (fig-forth-auto680):03786         * ======>>  135  <<
                      (fig-forth-auto680):03787         * ( adr n --- )
                      (fig-forth-auto680):03788         * Fill n bytes with ASCII SPACE.
1E7A 86               (fig-forth-auto680):03789                 FCB     $86
1E7B 424C414E4B       (fig-forth-auto680):03790                 FCC     'BLANK' ; 'BLANKS'
1E80 D3               (fig-forth-auto680):03791                 FCB     $D3
1E81 1E6A             (fig-forth-auto680):03792                 FDB     ERASE-8
1E83 17B9185E1E52     (fig-forth-auto680):03793         BLANKS  FDB     DOCOL,BL,FILL
1E89 1667             (fig-forth-auto680):03794                 FDB     SEMIS
                      (fig-forth-auto680):03795         *
                      (fig-forth-auto680):03796         * ======>>  136  <<
                      (fig-forth-auto680):03797         * ( c --- )
                      (fig-forth-auto680):03798         * Format a character at the left of the HLD output buffer.
1E8B 84               (fig-forth-auto680):03799                 FCB     $84
1E8C 484F4C           (fig-forth-auto680):03800                 FCC     'HOL'   ; 'HOLD'
1E8F C4               (fig-forth-auto680):03801                 FCB     $C4
1E90 1E7A             (fig-forth-auto680):03802                 FDB     BLANKS-9
1E92 17B91399FFFF1994 (fig-forth-auto680):03803         HOLD    FDB     DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
     1751199417721798
1EA2 1667             (fig-forth-auto680):03804                 FDB     SEMIS
                      (fig-forth-auto680):03805         *
                      (fig-forth-auto680):03806         * ======>>  137  <<
                      (fig-forth-auto680):03807         * ( --- adr )
                      (fig-forth-auto680):03808         * Give the address of the output PAD buffer. 
                      (fig-forth-auto680):03809         * PAD points to the end of a 68 byte buffer for numeric conversion.
1EA4 83               (fig-forth-auto680):03810                 FCB     $83
1EA5 5041             (fig-forth-auto680):03811                 FCC     'PA'    ; 'PAD'
1EA7 C4               (fig-forth-auto680):03812                 FCB     $C4
1EA8 1E8B             (fig-forth-auto680):03813                 FDB     HOLD-7
1EAA 17B919C713A7     (fig-forth-auto680):03814         PAD     FDB     DOCOL,HERE,LIT8
1EB0 44               (fig-forth-auto680):03815                 FCB     $44
1EB1 16C6             (fig-forth-auto680):03816                 FDB     PLUS
1EB3 1667             (fig-forth-auto680):03817                 FDB     SEMIS
                      (fig-forth-auto680):03818         *
                      (fig-forth-auto680):03819         * ######>> screen 48 <<
                      (fig-forth-auto680):03820         * ======>>  138  <<
                      (fig-forth-auto680):03821         * ( c --- )
                      (fig-forth-auto680):03822         * Scan a string terminated by the character c or ASCII NUL out of input;
                      (fig-forth-auto680):03823         * store symbol at WORDPAD with leading count byte and trailing ASCII NUL. 
                      (fig-forth-auto680):03824         * Leading c are passed over, per ENCLOSE.
                      (fig-forth-auto680):03825         * Scans from BLK, or from TIB if BLK is zero. 
                      (fig-forth-auto680):03826         * May overwrite the numeric conversion pad,
                      (fig-forth-auto680):03827         * if really long (length > 31) symbols are scanned.
1EB5 84               (fig-forth-auto680):03828                 FCB     $84
1EB6 574F52           (fig-forth-auto680):03829                 FCC     'WOR'   ; 'WORD'
1EB9 C4               (fig-forth-auto680):03830                 FCB     $C4
1EBA 1EA4             (fig-forth-auto680):03831                 FDB     PAD-6
1EBC 17B9190617721409 (fig-forth-auto680):03832         WORD    FDB     DOCOL,BLK,AT,ZBRAN
1EC4 000A             (fig-forth-auto680):03833                 FDB     WORD2-*-NATWID
1EC6 19061772249213FA (fig-forth-auto680):03834                 FDB     BLK,AT,BLOCK,BRAN
1ECE 0004             (fig-forth-auto680):03835                 FDB     WORD3-*-NATWID
1ED0 18BE1772         (fig-forth-auto680):03836         WORD2   FDB     TIB,AT
1ED4 190F177216C61736 (fig-forth-auto680):03837         WORD3   FDB     IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
     14FD19C713A7
1EE2 22               (fig-forth-auto680):03838                 FCB     34
1EE3 1E83190F1751171C (fig-forth-auto680):03839                 FDB     BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
     1A041681169C19C7
1EF3 179816C619C719AB (fig-forth-auto680):03840                 FDB     CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
     16901584
1EFF 1667             (fig-forth-auto680):03841                 FDB     SEMIS
                      (fig-forth-auto680):03842         *
                      (fig-forth-auto680):03843         * ######>> screen 49 <<
                      (fig-forth-auto680):03844         * ======>>  139  <<
                      (fig-forth-auto680):03845         * ( d1 string --- d2 adr )
                      (fig-forth-auto680):03846         * Convert the text at string into a number, accumulating the result into d1,
                      (fig-forth-auto680):03847         * leaving adr pointing to the first character not converted. 
                      (fig-forth-auto680):03848         * If DPL is non-negative at entry,
                      (fig-forth-auto680):03849         * accumulates the number of characters converted into DPL.
1F01 88               (fig-forth-auto680):03850                 FCB     $88
1F02 284E554D424552   (fig-forth-auto680):03851                 FCC     '(NUMBER'       ; '(NUMBER)'
1F09 A9               (fig-forth-auto680):03852                 FCB     $A9
1F0A 1EB5             (fig-forth-auto680):03853                 FDB     WORD-7
1F0C 17B9             (fig-forth-auto680):03854         PNUMB   FDB     DOCOL
1F0E 19AB17451681177E (fig-forth-auto680):03855         PNUMB2  FDB     ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
     1963177214741409
1F1E 002A             (fig-forth-auto680):03856                 FDB     PNUMB4-*-NATWID
1F20 17361963177215A5 (fig-forth-auto680):03857                 FDB     SWAP,BASE,AT,USTAR,DROP,ROT,BASE
     172A1A431963
1F2E 177215A516D4196D (fig-forth-auto680):03858                 FDB     AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
     177219AB1409
1F3C 0006             (fig-forth-auto680):03859                 FDB     PNUMB3-*-NATWID
1F3E 1845196D1751     (fig-forth-auto680):03860                 FDB     ONE,DPL,PSTORE
1F44 169013FA         (fig-forth-auto680):03861         PNUMB3  FDB     FROMR,BRAN
1F48 FFC4             (fig-forth-auto680):03862                 FDB     PNUMB2-*-NATWID
1F4A 1690             (fig-forth-auto680):03863         PNUMB4  FDB     FROMR
1F4C 1667             (fig-forth-auto680):03864                 FDB     SEMIS
                      (fig-forth-auto680):03865         *
                      (fig-forth-auto680):03866         * ======>>  140  <<
                      (fig-forth-auto680):03867         * ( ctstr --- d )
                      (fig-forth-auto680):03868         * Convert text at ctstr to a double integer,
                      (fig-forth-auto680):03869         * taking the 0 ERROR if the conversion is not valid. 
                      (fig-forth-auto680):03870         * If a decimal point is present,
                      (fig-forth-auto680):03871         * accumulate the count of digits to the decimal point's right into DPL
                      (fig-forth-auto680):03872         * (negative DPL at exit indicates single precision). 
                      (fig-forth-auto680):03873         * ctstr is a counted string
                      (fig-forth-auto680):03874         * -- the first byte at ctstr is the length of the string,
                      (fig-forth-auto680):03875         * but NUMBER ignores the count and expects a NUL terminator instead.
1F4E 86               (fig-forth-auto680):03876                 FCB     $86
1F4F 4E554D4245       (fig-forth-auto680):03877                 FCC     'NUMBE' ; 'NUMBER'
1F54 D2               (fig-forth-auto680):03878                 FCB     $D2
1F55 1F01             (fig-forth-auto680):03879                 FDB     PNUMB-11
1F57 17B9183D183D1A43 (fig-forth-auto680):03880         NUMB    FDB     DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
     174519AB177E13A7
1F67 2D               (fig-forth-auto680):03881                 FCC     "-"     minus sign
1F68 1A111745168116C6 (fig-forth-auto680):03882                 FDB     EQUAL,DUP,TOR,PLUS,LIT,$FFFF
     1399FFFF
1F74 196D178A1F0C1745 (fig-forth-auto680):03883         NUMB1   FDB     DPL,STORE,PNUMB,DUP,CAT,BL,SUB
     177E185E1A04
1F82 1409             (fig-forth-auto680):03884                 FDB     ZBRAN
1F84 0013             (fig-forth-auto680):03885                 FDB     NUMB2-*-NATWID
1F86 1745177E13A7     (fig-forth-auto680):03886                 FDB     DUP,CAT,LIT8
1F8C 2E               (fig-forth-auto680):03887                 FCC     "."
1F8D 1A04183D1B39183D (fig-forth-auto680):03888                 FDB     SUB,ZERO,QERR,ZERO,BRAN
     13FA
1F97 FFDB             (fig-forth-auto680):03889                 FDB     NUMB1-*-NATWID
1F99 172A16901409     (fig-forth-auto680):03890         NUMB2   FDB     DROP,FROMR,ZBRAN
1F9F 0002             (fig-forth-auto680):03891                 FDB     NUMB3-*-NATWID
1FA1 1702             (fig-forth-auto680):03892                 FDB     DMINUS
1FA3 1667             (fig-forth-auto680):03893         NUMB3   FDB     SEMIS
                      (fig-forth-auto680):03894         *
                      (fig-forth-auto680):03895         * ======>>  141  <<
                      (fig-forth-auto680):03896         * ( --- locptr length true )      { -FIND name } typical input
                      (fig-forth-auto680):03897         * ( --- false )
                      (fig-forth-auto680):03898         * Parse a word, then FIND,
                      (fig-forth-auto680):03899         * first in the definition vocabulary,
                      (fig-forth-auto680):03900         * then in the CONTEXT (interpretation) vocabulary, if necessary.
                      (fig-forth-auto680):03901         * Returns what (FIND) returns, flag and optional location and length.
1FA5 85               (fig-forth-auto680):03902                 FCB     $85
1FA6 2D46494E         (fig-forth-auto680):03903                 FCC     '-FIN'  ; '-FIND'
1FAA C4               (fig-forth-auto680):03904                 FCB     $C4
1FAB 1F4E             (fig-forth-auto680):03905                 FDB     NUMB-9
1FAD 17B9185E1EBC19C7 (fig-forth-auto680):03906         DFIND   FDB     DOCOL,BL,WORD,HERE,CONTXT,AT,AT
     193E17721772
1FBB 14AF174516A31409 (fig-forth-auto680):03907                 FDB     PFIND,DUP,ZEQU,ZBRAN
1FC3 0008             (fig-forth-auto680):03908                 FDB     DFIND2-*-NATWID
1FC5 172A19C71AD014AF (fig-forth-auto680):03909                 FDB     DROP,HERE,LATEST,PFIND
1FCD 1667             (fig-forth-auto680):03910         DFIND2  FDB     SEMIS
                      (fig-forth-auto680):03911         *
                      (fig-forth-auto680):03912         * ######>> screen 50 <<
                      (fig-forth-auto680):03913         * ======>>  142  <<
                      (fig-forth-auto680):03914         * ( anything --- nothing )        ( anything *** nothing )
                      (fig-forth-auto680):03915         * An indirection for ABORT, for ERROR,
                      (fig-forth-auto680):03916         * which may be modified carefully.
1FCF 87               (fig-forth-auto680):03917                 FCB     $87
1FD0 2841424F5254     (fig-forth-auto680):03918                 FCC     '(ABORT'        ; '(ABORT)'
1FD6 A9               (fig-forth-auto680):03919                 FCB     $A9
1FD7 1FA5             (fig-forth-auto680):03920                 FDB     DFIND-8
1FD9 17B92205         (fig-forth-auto680):03921         PABORT  FDB     DOCOL,ABORT
1FDD 1667             (fig-forth-auto680):03922                 FDB     SEMIS
                      (fig-forth-auto680):03923         *
                      (fig-forth-auto680):03924         * ======>>  143  <<
1FDF 85               (fig-forth-auto680):03925                 FCB     $85
1FE0 4552524F         (fig-forth-auto680):03926                 FCC     'ERRO'  ; 'ERROR'
1FE4 D2               (fig-forth-auto680):03927                 FCB     $D2
1FE5 1FCF             (fig-forth-auto680):03928                 FDB     PABORT-10
                      (fig-forth-auto680):03929         * This really should not be high level, according to best practices.
                      (fig-forth-auto680):03930         * But fixing that cascades through MESSAGE,
                      (fig-forth-auto680):03931         * requiring re-architecting the disk block system.
                      (fig-forth-auto680):03932         * First, we need to get this transliteration running.
1FE7 17B918D8177216B5 (fig-forth-auto680):03933         ERROR   FDB     DOCOL,WARN,AT,ZLESS
1FEF 1409             (fig-forth-auto680):03934                 FDB     ZBRAN
1FF1 0002             (fig-forth-auto680):03935                 FDB     ERROR2-*-NATWID
                      (fig-forth-auto680):03936         * note: WARNING is
                      (fig-forth-auto680):03937         * -1 to abort,
                      (fig-forth-auto680):03938         * 0 to print error #
                      (fig-forth-auto680):03939         * and 1 to print error message from disc
1FF3 1FD9             (fig-forth-auto680):03940                 FDB     PABORT
1FF5 19C71C9C1CAF1D10 (fig-forth-auto680):03941         ERROR2  FDB     HERE,COUNT,TYPE,PDOTQ
1FFD 0407             (fig-forth-auto680):03942                 FCB     4,7     ( bell )
1FFF 203F20           (fig-forth-auto680):03943                 FCC     " ? "
2002 252B164D190F1772 (fig-forth-auto680):03944                 FDB     MESS,SPSTOR,IN,AT,BLK,AT,QUIT
     1906177221D7
2010 1667             (fig-forth-auto680):03945                 FDB     SEMIS
                      (fig-forth-auto680):03946         *
                      (fig-forth-auto680):03947         * ======>>  144  <<
                      (fig-forth-auto680):03948         * ( n adr --- )
                      (fig-forth-auto680):03949         * Mask byte at adr with n.
                      (fig-forth-auto680):03950         * Not in FIG, don't need it for 8 bit characters after all.
                      (fig-forth-auto680):03951         *       FCB     $85
                      (fig-forth-auto680):03952         *       FCC     'CMAS'  ; 'CMASK'
                      (fig-forth-auto680):03953         *       FCB     $CB     ; 'K'
                      (fig-forth-auto680):03954         *       FDB     ERROR-8
                      (fig-forth-auto680):03955         * CMASK FDB     *+NATWID
                      (fig-forth-auto680):03956         *       LDX     ,U++    ; adr
                      (fig-forth-auto680):03957         *       LDD     ,U++    ; mask
                      (fig-forth-auto680):03958         *       ANDB    ,X
                      (fig-forth-auto680):03959         *       STB     ,X
                      (fig-forth-auto680):03960         *       RTS
                      (fig-forth-auto680):03961         *
                      (fig-forth-auto680):03962         * ( adr --- adr )
                      (fig-forth-auto680):03963         * Mask high bit of tail of name in PAD buffer.
                      (fig-forth-auto680):03964         * Not in FIG, need it for 8 bit characters.
2012 86               (fig-forth-auto680):03965                 FCB     $86
2013 4944464C41       (fig-forth-auto680):03966                 FCC     'IDFLA' ; 'IDFLAT'
2018 D4               (fig-forth-auto680):03967                 FCB     $D4     ; 'T'
2019 1FDF             (fig-forth-auto680):03968                 FDB     ERROR-8
201B 201D             (fig-forth-auto680):03969         IDFLAT  FDB     *+NATWID
201D AEC4             (fig-forth-auto680):03970                 LDX     ,U
201F E684             (fig-forth-auto680):03971                 LDB     ,X      ; get the count
2021 C43F             (fig-forth-auto680):03972                 ANDB    #CTMASK
2023 A685             (fig-forth-auto680):03973                 LDA     B,X     ; point to the tail
2025 847F             (fig-forth-auto680):03974                 ANDA    #$7F    ; Clear the EndOfName flag bit.
2027 A785             (fig-forth-auto680):03975                 STA     B,X
2029 39               (fig-forth-auto680):03976                 RTS
                      (fig-forth-auto680):03977         *
                      (fig-forth-auto680):03978         * ( symptr --- )
                      (fig-forth-auto680):03979         * Print definition's name from its NFA.
202A 83               (fig-forth-auto680):03980                 FCB     $83
202B 4944             (fig-forth-auto680):03981                 FCC     'ID'    ; 'ID.'
202D AE               (fig-forth-auto680):03982                 FCB     $AE
202E 2012             (fig-forth-auto680):03983                 FDB     IDFLAT-9
2030 17B91EAA13A7     (fig-forth-auto680):03984         IDDOT   FDB     DOCOL,PAD,LIT8
2036 20               (fig-forth-auto680):03985                 FCB     32
2037 13A7             (fig-forth-auto680):03986                 FDB     LIT8
2039 5F               (fig-forth-auto680):03987                 FCB     $5F     ( underline )
203A 1E5217451B121AE0 (fig-forth-auto680):03988                 FDB     FILL,DUP,PFA,LFA,OVER,SUB,PAD
     171C1A041EAA
                      (fig-forth-auto680):03989         *       FDB     SWAP,CMOVE,PAD,COUNT,LIT8
2048 173615841EAA     (fig-forth-auto680):03990                 FDB     SWAP,CMOVE,PAD
204E 201B             (fig-forth-auto680):03991                 FDB     IDFLAT
2050 1C9C13A7         (fig-forth-auto680):03992                 FDB     COUNT,LIT8
2054 1F               (fig-forth-auto680):03993                 FCB     31
2055 160E1CAF1A57     (fig-forth-auto680):03994                 FDB     AND,TYPE,SPACE
205B 1667             (fig-forth-auto680):03995                 FDB     SEMIS
                      (fig-forth-auto680):03996         *
                      (fig-forth-auto680):03997         * ######>> screen 51 <<
                      (fig-forth-auto680):03998         * ======>>  145  <<
                      (fig-forth-auto680):03999         * ( --- )         { CREATE name } input
                      (fig-forth-auto680):04000         * Parse a name (length < 32 characters) and create a header,
                      (fig-forth-auto680):04001         * reporting first duplicate found in either the defining vocabulary
                      (fig-forth-auto680):04002         * or the context (interpreting) vocabulary. 
                      (fig-forth-auto680):04003         * Install the header in the defining vocabulary
                      (fig-forth-auto680):04004         * with CFA dangerously pointing to the parameter field.
                      (fig-forth-auto680):04005         * Leave the name SMUDGEd.
205D 86               (fig-forth-auto680):04006                 FCB     $86
205E 4352454154       (fig-forth-auto680):04007                 FCC     'CREAT' ; 'CREATE'
2063 C5               (fig-forth-auto680):04008                 FCB     $C5
2064 202A             (fig-forth-auto680):04009                 FDB     IDDOT-6
2066 17B91FAD1409     (fig-forth-auto680):04010         CREATE  FDB     DOCOL,DFIND,ZBRAN
206C 0018             (fig-forth-auto680):04011                 FDB     CREAT2-*-NATWID
206E 172A1D10         (fig-forth-auto680):04012                 FDB     DROP,PDOTQ
2072 08               (fig-forth-auto680):04013                 FCB     8
2073 07               (fig-forth-auto680):04014                 FCB     7       ( bel )
2074 72656465663A20   (fig-forth-auto680):04015                 FCC     "redef: "
207B 1AFD203013A7     (fig-forth-auto680):04016                 FDB     NFA,IDDOT,LIT8
2081 04               (fig-forth-auto680):04017                 FCB     4
2082 252B1A57         (fig-forth-auto680):04018                 FDB     MESS,SPACE
2086 19C71745177E18CA (fig-forth-auto680):04019         CREAT2  FDB     HERE,DUP,CAT,WIDTH,AT,MIN
     17721A65
2092 19AB19D7174513A7 (fig-forth-auto680):04020                 FDB     ONEP,ALLOT,DUP,LIT8
209A A0               (fig-forth-auto680):04021                 FCB     ($80|FSMUDG)            ; Bracket the name.
209B 176519C718451A04 (fig-forth-auto680):04022                 FDB     TOGGLE,HERE,ONE,SUB,LIT8
     13A7
20A5 80               (fig-forth-auto680):04023                 FCB     $80
20A6 17651AD019E3194C (fig-forth-auto680):04024                 FDB     TOGGLE,LATEST,COMMA,CURENT,AT,STORE
     1772178A
                      (fig-forth-auto680):04025         *       FDB     HERE,TWOP,COMMA
20B2 19C7180219E3     (fig-forth-auto680):04026                 FDB     HERE,NATP,COMMA
20B8 1667             (fig-forth-auto680):04027                 FDB     SEMIS
                      (fig-forth-auto680):04028         *
                      (fig-forth-auto680):04029         * ######>> screen 52 <<
                      (fig-forth-auto680):04030         * ======>>  146  <<
                      (fig-forth-auto680):04031         * ( --- )                                         P
                      (fig-forth-auto680):04032         *                       { [COMPILE] name } typical use
                      (fig-forth-auto680):04033         * -DFIND next WORD and COMPILE it, literally;
                      (fig-forth-auto680):04034         * used to compile immediate definitions into words.
20BA C9               (fig-forth-auto680):04035                 FCB     $C9     immediate
20BB 5B434F4D50494C45 (fig-forth-auto680):04036                 FCC     '[COMPILE'      ; '[COMPILE]'
20C3 DD               (fig-forth-auto680):04037                 FCB     $DD
20C4 205D             (fig-forth-auto680):04038                 FDB     CREATE-9
20C6 17B91FAD16A3183D (fig-forth-auto680):04039         BCOMP   FDB     DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
     1B39172A1AEF19E3
20D6 1667             (fig-forth-auto680):04040                 FDB     SEMIS
                      (fig-forth-auto680):04041         *
                      (fig-forth-auto680):04042         * ======>>  147  <<
                      (fig-forth-auto680):04043         * ( n --- ) if compiling.                          P
                      (fig-forth-auto680):04044         * ( n --- n ) if interpreting.
                      (fig-forth-auto680):04045         * Compile n as a literal, if compiling.
20D8 C7               (fig-forth-auto680):04046                 FCB     $C7     immediate
20D9 4C4954455241     (fig-forth-auto680):04047                 FCC     'LITERA'        ; 'LITERAL'
20DF CC               (fig-forth-auto680):04048                 FCB     $CC
20E0 20BA             (fig-forth-auto680):04049                 FDB     BCOMP-12
20E2 17B9195817721409 (fig-forth-auto680):04050         LITER   FDB     DOCOL,STATE,AT,ZBRAN
20EA 0006             (fig-forth-auto680):04051                 FDB     LITER2-*-NATWID
20EC 1BC7139919E3     (fig-forth-auto680):04052                 FDB     COMPIL,LIT,COMMA
20F2 1667             (fig-forth-auto680):04053         LITER2  FDB     SEMIS
                      (fig-forth-auto680):04054         *
                      (fig-forth-auto680):04055         * ======>>  148  <<
                      (fig-forth-auto680):04056         * ( d --- )  if compiling.                        P
                      (fig-forth-auto680):04057         * ( d --- d ) if interpreting.
                      (fig-forth-auto680):04058         * Compile d as a double literal, if compiling.
20F4 C8               (fig-forth-auto680):04059                 FCB     $C8     immediate
20F5 444C4954455241   (fig-forth-auto680):04060                 FCC     'DLITERA'       ; 'DLITERAL'
20FC CC               (fig-forth-auto680):04061                 FCB     $CC
20FD 20D8             (fig-forth-auto680):04062                 FDB     LITER-10
20FF 17B9195817721409 (fig-forth-auto680):04063         DLITER  FDB     DOCOL,STATE,AT,ZBRAN
2107 0006             (fig-forth-auto680):04064                 FDB     DLITE2-*-NATWID
2109 173620E220E2     (fig-forth-auto680):04065                 FDB     SWAP,LITER,LITER        ; Just two literals in the right order.
210F 1667             (fig-forth-auto680):04066         DLITE2  FDB     SEMIS
                      (fig-forth-auto680):04067         *
                      (fig-forth-auto680):04068         * ######>> screen 53 <<
                      (fig-forth-auto680):04069         * ======>>  149  <<
                      (fig-forth-auto680):04070         * ( --- )
                      (fig-forth-auto680):04071         * Interpret or compile, according to STATE. 
                      (fig-forth-auto680):04072         * Searches words parsed in dictionary first, via -FIND,
                      (fig-forth-auto680):04073         * then checks for valid NUMBER.
                      (fig-forth-auto680):04074         * Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative. 
                      (fig-forth-auto680):04075         * ERROR checks the stack via ?STACK before returning to its caller. 
2111 89               (fig-forth-auto680):04076                 FCB     $89
2112 494E544552505245 (fig-forth-auto680):04077                 FCC     'INTERPRE'      ; 'INTERPRET'
211A D4               (fig-forth-auto680):04078                 FCB     $D4
211B 20F4             (fig-forth-auto680):04079                 FDB     DLITER-11
211D 17B9             (fig-forth-auto680):04080         INTERP  FDB     DOCOL
211F 1FAD1409         (fig-forth-auto680):04081         INTER2  FDB     DFIND,ZBRAN
2123 001A             (fig-forth-auto680):04082                 FDB     INTER5-*-NATWID
2125 195817721A1D     (fig-forth-auto680):04083                 FDB     STATE,AT,LESS
212B 1409             (fig-forth-auto680):04084                 FDB     ZBRAN
212D 0008             (fig-forth-auto680):04085                 FDB     INTER3-*-NATWID
212F 1AEF19E313FA     (fig-forth-auto680):04086                 FDB     CFA,COMMA,BRAN
2135 0004             (fig-forth-auto680):04087                 FDB     INTER4-*-NATWID
2137 1AEF13EB         (fig-forth-auto680):04088         INTER3  FDB     CFA,EXEC
213B 13FA             (fig-forth-auto680):04089         INTER4  FDB     BRAN
213D 0018             (fig-forth-auto680):04090                 FDB     INTER7-*-NATWID
213F 19C71F57196D1772 (fig-forth-auto680):04091         INTER5  FDB     HERE,NUMB,DPL,AT,ONEP,ZBRAN
     19AB1409
214B 0006             (fig-forth-auto680):04092                 FDB     INTER6-*-NATWID
214D 20FF13FA         (fig-forth-auto680):04093                 FDB     DLITER,BRAN
2151 0004             (fig-forth-auto680):04094                 FDB     INTER7-*-NATWID
2153 172A20E2         (fig-forth-auto680):04095         INTER6  FDB     DROP,LITER
2157 1D5B13FA         (fig-forth-auto680):04096         INTER7  FDB     QSTACK,BRAN
215B FFC2             (fig-forth-auto680):04097                 FDB     INTER2-*-NATWID
                      (fig-forth-auto680):04098         *       FDB     SEMIS   never executed
                      (fig-forth-auto680):04099         
                      (fig-forth-auto680):04100         *
                      (fig-forth-auto680):04101         * ######>> screen 54 <<
                      (fig-forth-auto680):04102         * ======>>  150  <<
                      (fig-forth-auto680):04103         * ( --- )
                      (fig-forth-auto680):04104         * Toggle precedence bit of LATEST definition header. 
                      (fig-forth-auto680):04105         * During compiling, most symbols scanned are compiled. 
                      (fig-forth-auto680):04106         * IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
                      (fig-forth-auto680):04107         * but may be compiled via ' (TICK).
215D 89               (fig-forth-auto680):04108                 FCB     $89
215E 494D4D4544494154 (fig-forth-auto680):04109                 FCC     'IMMEDIAT'      ; 'IMMEDIATE'
2166 C5               (fig-forth-auto680):04110                 FCB     $C5
2167 2111             (fig-forth-auto680):04111                 FDB     INTERP-12
2169 17B91AD013A7     (fig-forth-auto680):04112         IMMED   FDB     DOCOL,LATEST,LIT8
216F 40               (fig-forth-auto680):04113                 FCB     FIMMED
2170 1765             (fig-forth-auto680):04114                 FDB     TOGGLE
2172 1667             (fig-forth-auto680):04115                 FDB     SEMIS
                      (fig-forth-auto680):04116         *
                      (fig-forth-auto680):04117         * ======>>  151  <<
                      (fig-forth-auto680):04118         * ( --- )         { VOCABULARY name } input
                      (fig-forth-auto680):04119         * Create a vocabulary entry with a flag for terminating vocabulary searches.
                      (fig-forth-auto680):04120         * Store the current search context in it for linking.
                      (fig-forth-auto680):04121         * At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
2174 8A               (fig-forth-auto680):04122                 FCB     $8A
2175 564F434142554C41 (fig-forth-auto680):04123                 FCC     'VOCABULAR'     ; 'VOCABULARY'
     52
217E D9               (fig-forth-auto680):04124                 FCB     $D9
217F 215D             (fig-forth-auto680):04125                 FDB     IMMED-12
2181 17B91C6A139981A0 (fig-forth-auto680):04126         VOCAB   FDB     DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
     19E3194C17721AEF
2191 19E319C718FC1772 (fig-forth-auto680):04127                 FDB     COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
     19E318FC178A1C7A
                      (fig-forth-auto680):04128         * DOVOC FDB     TWOP,CONTXT,STORE
21A1 1802193E178A     (fig-forth-auto680):04129         DOVOC   FDB     NATP,CONTXT,STORE
21A7 1667             (fig-forth-auto680):04130                 FDB     SEMIS
                      (fig-forth-auto680):04131         *
                      (fig-forth-auto680):04132         * ======>>  152  <<
                      (fig-forth-auto680):04133         *
                      (fig-forth-auto680):04134         * Note: FORTH does not go here in the rom-able dictionary,
                      (fig-forth-auto680):04135         *    since FORTH is a type of variable.
                      (fig-forth-auto680):04136         *
                      (fig-forth-auto680):04137         * (Should make a proper architecture for this at some point.)
                      (fig-forth-auto680):04138         *
                      (fig-forth-auto680):04139         *
                      (fig-forth-auto680):04140         * ======>>  153  <<
                      (fig-forth-auto680):04141         * ( --- )
                      (fig-forth-auto680):04142         * Makes the current interpretation CONTEXT vocabulary
                      (fig-forth-auto680):04143         * also the CURRENT defining vocabulary.
21A9 8B               (fig-forth-auto680):04144                 FCB     $8B
21AA 444546494E495449 (fig-forth-auto680):04145                 FCC     'DEFINITION'    ; 'DEFINITIONS'
     4F4E
21B4 D3               (fig-forth-auto680):04146                 FCB     $D3
21B5 2174             (fig-forth-auto680):04147                 FDB     VOCAB-13
21B7 17B9193E1772194C (fig-forth-auto680):04148         DEFIN   FDB     DOCOL,CONTXT,AT,CURENT,STORE
     178A
21C1 1667             (fig-forth-auto680):04149                 FDB     SEMIS
                      (fig-forth-auto680):04150         *
                      (fig-forth-auto680):04151         * ======>>  154  <<
                      (fig-forth-auto680):04152         * ( --- )
                      (fig-forth-auto680):04153         * Parse out a comment and toss it away. 
                      (fig-forth-auto680):04154         * Leaves the first 32 characters in WORDPAD, which may or may not be useful.
21C3 C1               (fig-forth-auto680):04155                 FCB     $C1     immediate       (
21C4 A8               (fig-forth-auto680):04156                 FCB     $A8
21C5 21A9             (fig-forth-auto680):04157                 FDB     DEFIN-14
21C7 17B913A7         (fig-forth-auto680):04158         PAREN   FDB     DOCOL,LIT8
21CB 29               (fig-forth-auto680):04159                 FCC     ")"
21CC 1EBC             (fig-forth-auto680):04160                 FDB     WORD
21CE 1667             (fig-forth-auto680):04161                 FDB     SEMIS
                      (fig-forth-auto680):04162         *
                      (fig-forth-auto680):04163         * ######>> screen 55 <<
                      (fig-forth-auto680):04164         * ======>>  155  <<
                      (fig-forth-auto680):04165         * ( anything *** nothing )
                      (fig-forth-auto680):04166         * Clear return stack. 
                      (fig-forth-auto680):04167         * Then INTERPRET and, if not compiling, prompt with OK,
                      (fig-forth-auto680):04168         * in infinite loop.
21D0 84               (fig-forth-auto680):04169                 FCB     $84
21D1 515549           (fig-forth-auto680):04170                 FCC     'QUI'   ; 'QUIT'
21D4 D4               (fig-forth-auto680):04171                 FCB     $D4
21D5 21C3             (fig-forth-auto680):04172                 FDB     PAREN-4
21D7 17B9183D1906178A (fig-forth-auto680):04173         QUIT    FDB     DOCOL,ZERO,BLK,STORE
21DF 1BDD             (fig-forth-auto680):04174                 FDB     LBRAK
                      (fig-forth-auto680):04175         *
                      (fig-forth-auto680):04176         *  Here is the outer interpretter
                      (fig-forth-auto680):04177         *  which gets a line of input, does it, prints " OK"
                      (fig-forth-auto680):04178         *  then repeats :
21E1 165815771DFF211D (fig-forth-auto680):04179         QUIT2   FDB     RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
     1958177216A3
21EF 1409             (fig-forth-auto680):04180                 FDB     ZBRAN
21F1 0006             (fig-forth-auto680):04181                 FDB     QUIT3-*-NATWID
21F3 1D10             (fig-forth-auto680):04182                 FDB     PDOTQ
21F5 03               (fig-forth-auto680):04183                 FCB     3
21F6 204F4B           (fig-forth-auto680):04184                 FCC     ' OK'   ; ' OK'
21F9 13FA             (fig-forth-auto680):04185         QUIT3   FDB     BRAN
21FB FFE4             (fig-forth-auto680):04186                 FDB     QUIT2-*-NATWID
                      (fig-forth-auto680):04187         *       FDB     SEMIS   ( never executed )
                      (fig-forth-auto680):04188         *
                      (fig-forth-auto680):04189         * ======>>  156  <<
                      (fig-forth-auto680):04190         * ( anything --- nothing )        ( anything *** nothing )
                      (fig-forth-auto680):04191         * Clear parameter stack,
                      (fig-forth-auto680):04192         * set STATE to interpret and BASE to DECIMAL,
                      (fig-forth-auto680):04193         * return to input from terminal,
                      (fig-forth-auto680):04194         * restore DRIVE OFFSET to 0,
                      (fig-forth-auto680):04195         * print out "Forth-68",
                      (fig-forth-auto680):04196         * set interpret and define vocabularies to FORTH,
                      (fig-forth-auto680):04197         * and finally, QUIT. 
                      (fig-forth-auto680):04198         * Used to force the system to a known state
                      (fig-forth-auto680):04199         * and return control to the initial INTERPRETer.
21FD 85               (fig-forth-auto680):04200                 FCB     $85
21FE 41424F52         (fig-forth-auto680):04201                 FCC     'ABOR'  ; 'ABORT'
2202 D4               (fig-forth-auto680):04202                 FCB     $D4
2203 21D0             (fig-forth-auto680):04203                 FDB     QUIT-7
2205 17B9164D1C251D5B (fig-forth-auto680):04204         ABORT   FDB     DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
     242515771D10
2213 0A               (fig-forth-auto680):04205                 FCB     10
2214 466F7274682D3638 (fig-forth-auto680):04206                 FCC     "Forth-6809"
     3039
221E 2A9D21B7         (fig-forth-auto680):04207                 FDB     FORTH,DEFIN
2222 21D7             (fig-forth-auto680):04208                 FDB     QUIT
                      (fig-forth-auto680):04209         *       FDB     SEMIS   never executed
                      (fig-forth-auto680):04210                 PAGE
                      (fig-forth-auto680):04211         *
                      (fig-forth-auto680):04212         * ######>> screen 56 <<
                      (fig-forth-auto680):04213         * bootstrap code... moves rom contents to ram :
                      (fig-forth-auto680):04214         * ======>>  157  <<
2224 84               (fig-forth-auto680):04215                 FCB     $84
2225 434F4C           (fig-forth-auto680):04216                 FCC     'COL'   ; 'COLD'
2228 C4               (fig-forth-auto680):04217                 FCB     $C4
2229 21FD             (fig-forth-auto680):04218                 FDB     ABORT-8
222B 222D             (fig-forth-auto680):04219         COLD    FDB     *+NATWID
                      (fig-forth-auto680):04220         * Ultimately, we want position indepence,
                      (fig-forth-auto680):04221         * so I'm using PCR where it seems reasonable.
222D 10EE8DEFE0       (fig-forth-auto680):04222         CENT    LDS     SINIT,PCR       ; Get a useable return stack, at least.
2232 867C             (fig-forth-auto680):04223                 LDA     #IUPDP          ; This is not relative to PC.
2234 1F8B             (fig-forth-auto680):04224                 TFR     A,DP            ; And a useable direct page, too.
     7C               (fig-forth-auto680):04225                 SETDP   IUPDP   ; (For good measure.)
                      (fig-forth-auto680):04226         *
                      (fig-forth-auto680):04227         * We'll keep this here for the time being.
                      (fig-forth-auto680):04228         * There are better ways to do this, of course.
                      (fig-forth-auto680):04229         * Re-architect, re-architect.
2236 308D006A         (fig-forth-auto680):04230                 LEAX    RAM,PCR 
223A 9F28             (fig-forth-auto680):04231                 STX     <XFENCE ; Borrow this variable for a loop terminator.
223C 318D0890         (fig-forth-auto680):04232                 LEAY    REND,PCR        ; top of destination
2240 308D00A3         (fig-forth-auto680):04233                 LEAX    ERAM,PCR        ; top of stuff to move
2244 A682             (fig-forth-auto680):04234         COLD2   LDA     ,-X
2246 A7A2             (fig-forth-auto680):04235                 STA     ,-Y     ; move TASK & FORTH to ram
2248 9C28             (fig-forth-auto680):04236                 CMPX    <XFENCE
224A 26F8             (fig-forth-auto680):04237                 BNE     COLD2
                      (fig-forth-auto680):04238         *
                      (fig-forth-auto680):04239         * CENT  LDS     #REND-1 top of destination
                      (fig-forth-auto680):04240         *       LDX     #ERAM   top of stuff to move
                      (fig-forth-auto680):04241         * COLD2 LEAX -1,X       ; 
                      (fig-forth-auto680):04242         *       LDA 0,X
                      (fig-forth-auto680):04243         *       PSHS A  ; move TASK & FORTH to ram
                      (fig-forth-auto680):04244         *       CMPX    #RAM
                      (fig-forth-auto680):04245         *       BNE     COLD2
                      (fig-forth-auto680):04246         *
                      (fig-forth-auto680):04247         *       LDS     #XFENCE-1       put stack at a safe place for now
                      (fig-forth-auto680):04248         *                               But that is taken care of.
                      (fig-forth-auto680):04249         *       LDX     COLINT
                      (fig-forth-auto680):04250         *       STX     XCOLUM
224C AE8DEFD2         (fig-forth-auto680):04251                 LDX     COLINT,PCR
2250 9F4C             (fig-forth-auto680):04252                 STX     <XCOLUM
                      (fig-forth-auto680):04253         *       LDX     DELINT
                      (fig-forth-auto680):04254         *       STX     XDELAY
2252 AE8DEFCE         (fig-forth-auto680):04255                 LDX     DELINT,PCR
2256 9F4A             (fig-forth-auto680):04256                 STX     <XDELAY
                      (fig-forth-auto680):04257         *       LDX     VOCINT
                      (fig-forth-auto680):04258         *       STX     XVOCL
2258 AE8DEFC4         (fig-forth-auto680):04259                 LDX     VOCINT,PCR
225C 9F2C             (fig-forth-auto680):04260                 STX     <XVOCL
                      (fig-forth-auto680):04261         *       LDX     DPINIT
                      (fig-forth-auto680):04262         *       STX     XDICTP
225E AE8DEFBC         (fig-forth-auto680):04263                 LDX     DPINIT,PCR
2262 9F2A             (fig-forth-auto680):04264                 STX     <XDICTP
                      (fig-forth-auto680):04265         *       LDX     FENCIN
                      (fig-forth-auto680):04266         *       STX     XFENCE
2264 AE8DEFB4         (fig-forth-auto680):04267                 LDX     FENCIN,PCR
2268 9F28             (fig-forth-auto680):04268                 STX     <XFENCE
                      (fig-forth-auto680):04269         *
226A 10EE8DEFA3       (fig-forth-auto680):04270         WENT    LDS     SINIT,PCR       ; Get a useable return stack, at least.
226F 867C             (fig-forth-auto680):04271                 LDA     #IUPDP          ; This is not relative to PC.
2271 1F8B             (fig-forth-auto680):04272                 TFR     A,DP            ; And a useable direct page, too.
     7C               (fig-forth-auto680):04273                 SETDP   IUPDP   ; (For good measure.)
                      (fig-forth-auto680):04274         *
2273 308DEF9B         (fig-forth-auto680):04275                 LEAX    SINIT,PCR
2277 3410             (fig-forth-auto680):04276                 PSHS    X       ; for loop termination
2279 5F               (fig-forth-auto680):04277                 CLRB            ; Yes, I'm being a little ridiculous. Only a little.
227A 1F02             (fig-forth-auto680):04278                 TFR     D,Y
227C 31A828           (fig-forth-auto680):04279                 LEAY    XFENCE-UORIG,Y  ; top of destination
227F 308DEF99         (fig-forth-auto680):04280                 LEAX    FENCIN,PCR      ; top of stuff to move
2283 EC83             (fig-forth-auto680):04281         WARM2   LDD     ,--X    ; All entries are 16 bit.
2285 EDA3             (fig-forth-auto680):04282                 STD     ,--Y
2287 ACE4             (fig-forth-auto680):04283                 CMPX    ,S
2289 26F8             (fig-forth-auto680):04284                 BNE     WARM2
228B 3262             (fig-forth-auto680):04285                 LEAS    2,S     ; But we'll reset the return stack shortly, anyway.
                      (fig-forth-auto680):04286         * WENT  LDS     #XFENCE-1       top of destination
                      (fig-forth-auto680):04287         *       LDX     #FENCIN         top of stuff to move
                      (fig-forth-auto680):04288         * WARM2 LEAX -1,X       ; 
                      (fig-forth-auto680):04289         *       LDA 0,X
                      (fig-forth-auto680):04290         *       PSHS A  ; 
                      (fig-forth-auto680):04291         *       CMPX    #SINIT
                      (fig-forth-auto680):04292         *       BNE     WARM2
                      (fig-forth-auto680):04293         *
                      (fig-forth-auto680):04294         *       LDS     SINIT
                      (fig-forth-auto680):04295         * S is already there.
                      (fig-forth-auto680):04296         *       LDX     UPINIT
                      (fig-forth-auto680):04297         *       STX     UP              init user ram pointer
                      (fig-forth-auto680):04298         * UP is already there (DP).
                      (fig-forth-auto680):04299         *       LDX     #ABORT
                      (fig-forth-auto680):04300         *       STX     IP
228D 318DFF76         (fig-forth-auto680):04301                 LEAY    ABORT+NATWID,PCR        ; IP never points to DOCOL!
                      (fig-forth-auto680):04302         *
2291 12               (fig-forth-auto680):04303                 NOP             Here is a place to jump to special user
2292 12               (fig-forth-auto680):04304                 NOP             initializations such as I/0 interrups
2293 12               (fig-forth-auto680):04305                 NOP
                      (fig-forth-auto680):04306         *
                      (fig-forth-auto680):04307         * For systems with TRACE:
2294 8E0000           (fig-forth-auto680):04308                 LDX     #00
                      (fig-forth-auto680):04309         *       STX     TRLIM   clear trace mode
2297 9F0A             (fig-forth-auto680):04310                 STX     <TRLIM  clear trace mode (both bytes)
2299 8E0000           (fig-forth-auto680):04311                 LDX     #0
                      (fig-forth-auto680):04312         *       STX     BRKPT   clear breakpoint address
229C 9F0C             (fig-forth-auto680):04313                 STX     <BRKPT  clear breakpoint address
                      (fig-forth-auto680):04314         *       JMP     RPSTOR+2 start the virtual machine running !
229E 17F3B9           (fig-forth-auto680):04315                 LBSR    RPSTOR+NATWID start the virtual machine running !
22A1 16EF84           (fig-forth-auto680):04316                 LBRA    NEXT    ; But we must also give RP! someplace to return.
                      (fig-forth-auto680):04317         *       RP! sets up the return stack pointer, then Y references abort.
                      (fig-forth-auto680):04318         *
                      (fig-forth-auto680):04319         * Here is the stuff that gets copied to ram :
                      (fig-forth-auto680):04320         * (not * at address $140:)
                      (fig-forth-auto680):04321         * at an appropriate address:
                      (fig-forth-auto680):04322         *
22A4 3000300000000000 (fig-forth-auto680):04323         RAM     FDB     $3000,$3000,0,0
                      (fig-forth-auto680):04324                 
                      (fig-forth-auto680):04325         * ======>>  (152)  <<
                      (fig-forth-auto680):04326         * ( --- )                                                 P
                      (fig-forth-auto680):04327         * Makes FORTH the current interpretation vocabulary.
                      (fig-forth-auto680):04328         * In order to make this ROMmable, this entry is set up as the tail-end, 
                      (fig-forth-auto680):04329         * and copied to RAM in the start-up code.
                      (fig-forth-auto680):04330         * We want a more elegant solution to this, too. Greedy, maybe.
22AC C5               (fig-forth-auto680):04331                 FCB     $C5     immediate
22AD 464F5254         (fig-forth-auto680):04332                 FCC     'FORT'  ; 'FORTH'
22B1 C8               (fig-forth-auto680):04333                 FCB     $C8
22B2 2A7C             (fig-forth-auto680):04334                 FDB     NOOP-7  ; Note that this does not link to COLD!
22B4 1C8621A181A02AC5 (fig-forth-auto680):04335         RFORTH  FDB     DODOES,DOVOC,$81A0,TASK-7
22BC 0000             (fig-forth-auto680):04336                 FDB     0
22BE 28432920466F7274 (fig-forth-auto680):04337                 FCC     "(C) Forth Interest Group, 1979"
     6820496E74657265
     73742047726F7570
     2C2031393739
22DC 84               (fig-forth-auto680):04338                 FCB     $84
22DD 544153           (fig-forth-auto680):04339                 FCC     'TAS'   ; 'TASK'
22E0 CB               (fig-forth-auto680):04340                 FCB     $CB
22E1 2A95             (fig-forth-auto680):04341                 FDB     FORTH-8
22E3 17B91667         (fig-forth-auto680):04342         RTASK   FDB     DOCOL,SEMIS
22E7 4461766964204C69 (fig-forth-auto680):04343         ERAM    FCC     "David Lion"    
     6F6E
                      (fig-forth-auto680):04344                 PAGE
                      (fig-forth-auto680):04345         *
                      (fig-forth-auto680):04346         * ######>> screen 57 <<
                      (fig-forth-auto680):04347         * ======>>  158  <<
                      (fig-forth-auto680):04348         * ( n0 --- d0 )
                      (fig-forth-auto680):04349         * Sign extend n0 to a double integer.
22F1 84               (fig-forth-auto680):04350                 FCB     $84
22F2 532D3E           (fig-forth-auto680):04351                 FCC     'S->'   ; 'S->D'
22F5 C4               (fig-forth-auto680):04352                 FCB     $C4
22F6 2224             (fig-forth-auto680):04353                 FDB     COLD-7  ; Note that this does not link to FORTH (RFORTH)!
22F8 17B9174516B516EF (fig-forth-auto680):04354         STOD    FDB     DOCOL,DUP,ZLESS,MINUS
2300 1667             (fig-forth-auto680):04355                 FDB     SEMIS
                      (fig-forth-auto680):04356         
                      (fig-forth-auto680):04357         
                      (fig-forth-auto680):04358         *
                      (fig-forth-auto680):04359         * ======>>  159  <<
                      (fig-forth-auto680):04360         * ( multiplier multiplicand --- product )
                      (fig-forth-auto680):04361         * Signed word multiply.
2302 81               (fig-forth-auto680):04362                 FCB     $81     ; *
2303 AA               (fig-forth-auto680):04363                 FCB     $AA
2304 22F1             (fig-forth-auto680):04364                 FDB     STOD-7
2306 2308             (fig-forth-auto680):04365         STAR    FDB     *+NATWID
2308 17F29C           (fig-forth-auto680):04366                 LBSR    USTAR+NATWID    ; or [USTAR,PCR]?
230B 3342             (fig-forth-auto680):04367                 LEAU    NATWID,U        ; Drop high word.
230D 39               (fig-forth-auto680):04368                 RTS
                      (fig-forth-auto680):04369         *       JSR     USTARS
                      (fig-forth-auto680):04370         *       LEAS 1,S        ; 
                      (fig-forth-auto680):04371         *       LEAS 1,S        ; 
                      (fig-forth-auto680):04372         *       JMP     NEXT
                      (fig-forth-auto680):04373         *
                      (fig-forth-auto680):04374         * ======>>  160  <<
                      (fig-forth-auto680):04375         * ( dividend divisor --- remainder quotient )
                      (fig-forth-auto680):04376         * M/ in word-only form, i. e., signed division of 2nd word by top word,
                      (fig-forth-auto680):04377         * yielding signed word quotient and remainder.
230E 84               (fig-forth-auto680):04378                 FCB     $84
230F 2F4D4F           (fig-forth-auto680):04379                 FCC     '/MO'   ; '/MOD'
2312 C4               (fig-forth-auto680):04380                 FCB     $C4
2313 2302             (fig-forth-auto680):04381                 FDB     STAR-4
2315 17B9168122F81690 (fig-forth-auto680):04382         SLMOD   FDB     DOCOL,TOR,STOD,FROMR,USLASH
     15DB
231F 1667             (fig-forth-auto680):04383                 FDB     SEMIS
                      (fig-forth-auto680):04384         *
                      (fig-forth-auto680):04385         * ======>>  161  <<
                      (fig-forth-auto680):04386         * ( dividend divisor --- quotient )
                      (fig-forth-auto680):04387         * Signed word divide without remainder.
2321 81               (fig-forth-auto680):04388                 FCB     $81     ; /
2322 AF               (fig-forth-auto680):04389                 FCB     $AF
2323 230E             (fig-forth-auto680):04390                 FDB     SLMOD-7
2325 17B923151736172A (fig-forth-auto680):04391         SLASH   FDB     DOCOL,SLMOD,SWAP,DROP
232D 1667             (fig-forth-auto680):04392                 FDB     SEMIS
                      (fig-forth-auto680):04393         *
                      (fig-forth-auto680):04394         * ======>>  162  <<
                      (fig-forth-auto680):04395         * ( dividend divisor --- remainder )
                      (fig-forth-auto680):04396         * Remainder function, result takes sign of dividend.
232F 83               (fig-forth-auto680):04397                 FCB     $83
2330 4D4F             (fig-forth-auto680):04398                 FCC     'MO'    ; 'MOD'
2332 C4               (fig-forth-auto680):04399                 FCB     $C4
2333 2321             (fig-forth-auto680):04400                 FDB     SLASH-4
2335 17B92315172A     (fig-forth-auto680):04401         MOD     FDB     DOCOL,SLMOD,DROP
233B 1667             (fig-forth-auto680):04402                 FDB     SEMIS
                      (fig-forth-auto680):04403         *
                      (fig-forth-auto680):04404         * ======>>  163  <<
                      (fig-forth-auto680):04405         * ( multiplier multiplicand divisor --- remainder quotient )
                      (fig-forth-auto680):04406         * Signed precise division of product:
                      (fig-forth-auto680):04407         * multiply 2nd and 3rd words on stack
                      (fig-forth-auto680):04408         * and divide the 31-bit product by the top word,
                      (fig-forth-auto680):04409         * leaving both quotient and remainder.
                      (fig-forth-auto680):04410         * Remainder takes sign of product. 
                      (fig-forth-auto680):04411         * Guaranteed not to lose significant bits in 16 bit integer math.
233D 85               (fig-forth-auto680):04412                 FCB     $85
233E 2A2F4D4F         (fig-forth-auto680):04413                 FCC     '*/MO'  ; '*/MOD'
2342 C4               (fig-forth-auto680):04414                 FCB     $C4
2343 232F             (fig-forth-auto680):04415                 FDB     MOD-6
2345 17B9168115A51690 (fig-forth-auto680):04416         SSMOD   FDB     DOCOL,TOR,USTAR,FROMR,USLASH
     15DB
234F 1667             (fig-forth-auto680):04417                 FDB     SEMIS
                      (fig-forth-auto680):04418         *
                      (fig-forth-auto680):04419         * ======>>  164  <<
                      (fig-forth-auto680):04420         * ( multiplier multiplicand divisor --- quotient )
                      (fig-forth-auto680):04421         *   */MOD without remainder.
2351 82               (fig-forth-auto680):04422                 FCB     $82
2352 2A               (fig-forth-auto680):04423                 FCC     '*'     ; '*/'
2353 AF               (fig-forth-auto680):04424                 FCB     $AF
2354 233D             (fig-forth-auto680):04425                 FDB     SSMOD-8
2356 17B923451736172A (fig-forth-auto680):04426         SSLASH  FDB     DOCOL,SSMOD,SWAP,DROP
235E 1667             (fig-forth-auto680):04427                 FDB     SEMIS
                      (fig-forth-auto680):04428         *
                      (fig-forth-auto680):04429         * ======>>  165  <<
                      (fig-forth-auto680):04430         * ( ud1 u1 --- u2 ud2 )
                      (fig-forth-auto680):04431         * U/ with an (unsigned) double quotient. 
                      (fig-forth-auto680):04432         * Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
                      (fig-forth-auto680):04433         * if you are prepared to deal with the extra 16 bits of result.
2360 85               (fig-forth-auto680):04434                 FCB     $85
2361 4D2F4D4F         (fig-forth-auto680):04435                 FCC     'M/MO'  ; 'M/MOD'
2365 C4               (fig-forth-auto680):04436                 FCB     $C4
2366 2351             (fig-forth-auto680):04437                 FDB     SSLASH-5
2368 17B91681183D169C (fig-forth-auto680):04438         MSMOD   FDB     DOCOL,TOR,ZERO,R,USLASH
     15DB
2372 16901736168115DB (fig-forth-auto680):04439                 FDB     FROMR,SWAP,TOR,USLASH,FROMR
     1690
237C 1667             (fig-forth-auto680):04440                 FDB     SEMIS
                      (fig-forth-auto680):04441         *
                      (fig-forth-auto680):04442         * ======>>  166  <<
                      (fig-forth-auto680):04443         * ( n>=0 --- n )
                      (fig-forth-auto680):04444         * ( n<0 --- -n )
                      (fig-forth-auto680):04445         * Convert the top of stack to its absolute value.
237E 83               (fig-forth-auto680):04446                 FCB     $83
237F 4142             (fig-forth-auto680):04447                 FCC     'AB'    ; 'ABS'
2381 D3               (fig-forth-auto680):04448                 FCB     $D3
2382 2360             (fig-forth-auto680):04449                 FDB     MSMOD-8
2384 17B9174516B51409 (fig-forth-auto680):04450         ABS     FDB     DOCOL,DUP,ZLESS,ZBRAN
238C 0002             (fig-forth-auto680):04451                 FDB     ABS2-*-NATWID
238E 16EF             (fig-forth-auto680):04452                 FDB     MINUS
2390 1667             (fig-forth-auto680):04453         ABS2    FDB     SEMIS
                      (fig-forth-auto680):04454         *
                      (fig-forth-auto680):04455         * ======>>  167  <<
                      (fig-forth-auto680):04456         * ( d>=0 --- d )
                      (fig-forth-auto680):04457         * ( d<0 --- -d )
                      (fig-forth-auto680):04458         * Convert the top double to its absolute value.
2392 84               (fig-forth-auto680):04459                 FCB     $84
2393 444142           (fig-forth-auto680):04460                 FCC     'DAB'   ; 'DABS'
2396 D3               (fig-forth-auto680):04461                 FCB     $D3
2397 237E             (fig-forth-auto680):04462                 FDB     ABS-6
2399 17B9174516B51409 (fig-forth-auto680):04463         DABS    FDB     DOCOL,DUP,ZLESS,ZBRAN
23A1 0002             (fig-forth-auto680):04464                 FDB     DABS2-*-NATWID
23A3 1702             (fig-forth-auto680):04465                 FDB     DMINUS
23A5 1667             (fig-forth-auto680):04466         DABS2   FDB     SEMIS
                      (fig-forth-auto680):04467         *
                      (fig-forth-auto680):04468         * ######>> screen 58 <<
                      (fig-forth-auto680):04469         * Disc primitives :
                      (fig-forth-auto680):04470         * ======>>  168  <<
                      (fig-forth-auto680):04471         * ( --- vadr )   
                      (fig-forth-auto680):04472         * Least Recently Used buffer.
                      (fig-forth-auto680):04473         * Really should be with FIRST and LIMIT in the per-task table.
23A7 83               (fig-forth-auto680):04474                 FCB     $83
23A8 5553             (fig-forth-auto680):04475                 FCC     'US'    ; 'USE'
23AA C5               (fig-forth-auto680):04476                 FCB     $C5
23AB 2392             (fig-forth-auto680):04477                 FDB     DABS-7
23AD 17E9             (fig-forth-auto680):04478         USE     FDB     DOCON
23AF 7C58             (fig-forth-auto680):04479                 FDB     XUSE
                      (fig-forth-auto680):04480         * ======>>  169  <<
                      (fig-forth-auto680):04481         * ( --- vadr )   
                      (fig-forth-auto680):04482         * Most Recently Used buffer.
                      (fig-forth-auto680):04483         * Really should be with FIRST and LIMIT in the per-task table.
23B1 84               (fig-forth-auto680):04484                 FCB     $84
23B2 505245           (fig-forth-auto680):04485                 FCC     'PRE'   ; 'PREV'
23B5 D6               (fig-forth-auto680):04486                 FCB     $D6
23B6 23A7             (fig-forth-auto680):04487                 FDB     USE-6
23B8 17E9             (fig-forth-auto680):04488         PREV    FDB     DOCON
23BA 7C5A             (fig-forth-auto680):04489                 FDB     XPREV
                      (fig-forth-auto680):04490         * ======>>  170  <<
                      (fig-forth-auto680):04491         * ( buffer1 --- buffer2 f )
                      (fig-forth-auto680):04492         * Bump to next buffer,
                      (fig-forth-auto680):04493         * flag false if result is PREVious buffer,
                      (fig-forth-auto680):04494         * otherwise flag true. 
                      (fig-forth-auto680):04495         * Used in the LRU allocation routines.
23BC 84               (fig-forth-auto680):04496                 FCB     $84
23BD 2B4255           (fig-forth-auto680):04497                 FCC     '+BU'   ; '+BUF'
23C0 C6               (fig-forth-auto680):04498                 FCB     $C6
23C1 23B1             (fig-forth-auto680):04499                 FDB     PREV-7
23C3 17B913A7         (fig-forth-auto680):04500         PBUF    FDB     DOCOL,LIT8
23C7 84               (fig-forth-auto680):04501                 FCB     $84
23C8 16C6174518761A11 (fig-forth-auto680):04502                 FDB     PLUS,DUP,LIMIT,EQUAL,ZBRAN
     1409
23D2 0004             (fig-forth-auto680):04503                 FDB     PBUF2-*-NATWID
23D4 172A186A         (fig-forth-auto680):04504                 FDB     DROP,FIRST
23D8 174523B817721A04 (fig-forth-auto680):04505         PBUF2   FDB     DUP,PREV,AT,SUB
23E0 1667             (fig-forth-auto680):04506                 FDB     SEMIS
                      (fig-forth-auto680):04507         *
                      (fig-forth-auto680):04508         * ======>>  171  <<
                      (fig-forth-auto680):04509         * ( --- )
                      (fig-forth-auto680):04510         * Mark PREVious buffer dirty, in need of being written out.
23E2 86               (fig-forth-auto680):04511                 FCB     $86
23E3 5550444154       (fig-forth-auto680):04512                 FCC     'UPDAT' ; 'UPDATE'
23E8 C5               (fig-forth-auto680):04513                 FCB     $C5
23E9 23BC             (fig-forth-auto680):04514                 FDB     PBUF-7
23EB 17B923B817721772 (fig-forth-auto680):04515         UPDATE  FDB     DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
     13998000161E23B8
     1772178A
23FF 1667             (fig-forth-auto680):04516                 FDB     SEMIS
                      (fig-forth-auto680):04517         *
                      (fig-forth-auto680):04518         * ======>>  172  <<
                      (fig-forth-auto680):04519         * ( --- )
                      (fig-forth-auto680):04520         * Mark all buffers empty. 
                      (fig-forth-auto680):04521         * Standard method of discarding changes.
2401 8D               (fig-forth-auto680):04522                 FCB     $8D
2402 454D5054592D4255 (fig-forth-auto680):04523                 FCC     'EMPTY-BUFFER'  ; 'EMPTY-BUFFERS'
     46464552
240E D3               (fig-forth-auto680):04524                 FCB     $D3
240F 23E2             (fig-forth-auto680):04525                 FDB     UPDATE-9
2411 17B9186A1876171C (fig-forth-auto680):04526         MTBUF   FDB     DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
     1A041E72
241D 1667             (fig-forth-auto680):04527                 FDB     SEMIS
                      (fig-forth-auto680):04528         *
                      (fig-forth-auto680):04529         * ======>>  173  <<
                      (fig-forth-auto680):04530         * ( --- )
                      (fig-forth-auto680):04531         * Clear the current offset to the block numbers in the drive interface.
                      (fig-forth-auto680):04532         * The drives need to be re-architected.
                      (fig-forth-auto680):04533         * Would be cool to have RAM and ROM drives supported
                      (fig-forth-auto680):04534         * in addition to regular physical persistent store.
241F 83               (fig-forth-auto680):04535                 FCB     $83
2420 4452             (fig-forth-auto680):04536                 FCC     'DR'    ; 'DR0'
2422 B0               (fig-forth-auto680):04537                 FCB     $B0
2423 2401             (fig-forth-auto680):04538                 FDB     MTBUF-16
2425 17B9183D1930178A (fig-forth-auto680):04539         DRZERO  FDB     DOCOL,ZERO,OFSET,STORE
242D 1667             (fig-forth-auto680):04540                 FDB     SEMIS
                      (fig-forth-auto680):04541         *
                      (fig-forth-auto680):04542         * ======>>  174  <<== system dependant word
                      (fig-forth-auto680):04543         * ( --- )
                      (fig-forth-auto680):04544         * Set the current offset in the drive interface to reference the second drive.
                      (fig-forth-auto680):04545         * The hard-coded number in there needs to be in a table.
242F 83               (fig-forth-auto680):04546                 FCB     $83
2430 4452             (fig-forth-auto680):04547                 FCC     'DR'    ; 'DR1'
2432 B1               (fig-forth-auto680):04548                 FCB     $B1
2433 241F             (fig-forth-auto680):04549                 FDB     DRZERO-6
2435 17B9139907D01930 (fig-forth-auto680):04550         DRONE   FDB     DOCOL,LIT,$07D0,OFSET,STORE
     178A
243F 1667             (fig-forth-auto680):04551                 FDB     SEMIS
                      (fig-forth-auto680):04552         *
                      (fig-forth-auto680):04553         * ######>> screen 59 <<
                      (fig-forth-auto680):04554         * ======>>  175  <<
                      (fig-forth-auto680):04555         * ( n --- buffer )
                      (fig-forth-auto680):04556         * Get a free buffer,
                      (fig-forth-auto680):04557         * assign it to block n,
                      (fig-forth-auto680):04558         * return buffer address.
                      (fig-forth-auto680):04559         * Will free a buffer by writing it, if necessary. 
                      (fig-forth-auto680):04560         * Does not actually read the block. 
                      (fig-forth-auto680):04561         * A bug in the fig LRU algorithm, which I have not fixed,
                      (fig-forth-auto680):04562         * gives the PREVious buffer if USE gets set to PREVious.
                      (fig-forth-auto680):04563         * (The bug is that USE sometimes gets set to PREVious.) 
                      (fig-forth-auto680):04564         * This bug sometimes causes sector moves to become sector fills.
2441 86               (fig-forth-auto680):04565                 FCB     $86
2442 4255464645       (fig-forth-auto680):04566                 FCC     'BUFFE' ; 'BUFFER'
2447 D2               (fig-forth-auto680):04567                 FCB     $D2
2448 242F             (fig-forth-auto680):04568                 FDB     DRONE-6
244A 17B923AD17721745 (fig-forth-auto680):04569         BUFFER  FDB     DOCOL,USE,AT,DUP,TOR
     1681
2454 23C31409         (fig-forth-auto680):04570         BUFFR2  FDB     PBUF,ZBRAN
2458 FFFA             (fig-forth-auto680):04571                 FDB     BUFFR2-*-NATWID
245A 23AD178A169C1772 (fig-forth-auto680):04572                 FDB     USE,STORE,R,AT,ZLESS
     16B5
2464 1409             (fig-forth-auto680):04573                 FDB     ZBRAN
2466 0012             (fig-forth-auto680):04574                 FDB     BUFFR3-*-NATWID
                      (fig-forth-auto680):04575         *       FDB     R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
2468 169C1802169C1772 (fig-forth-auto680):04576                 FDB     R,NATP,R,AT,LIT,$7FFF,AND,ZERO,RW
     13997FFF160E183D
     263B
                      (fig-forth-auto680):04577         * BUFFR3        FDB     R,STORE,R,PREV,STORE,FROMR,TWOP
247A 169C178A169C23B8 (fig-forth-auto680):04578         BUFFR3  FDB     R,STORE,R,PREV,STORE,FROMR,NATP
     178A16901802
2488 1667             (fig-forth-auto680):04579                 FDB     SEMIS
                      (fig-forth-auto680):04580         *
                      (fig-forth-auto680):04581         * ######>> screen 60 <<
                      (fig-forth-auto680):04582         * ======>>  176  <<
                      (fig-forth-auto680):04583         * ( n --- buffer )
                      (fig-forth-auto680):04584         * Get BUFFER containing block n, relative to OFFSET. 
                      (fig-forth-auto680):04585         * If block n is not in a buffer, bring it in. 
                      (fig-forth-auto680):04586         * Returns buffer address.
248A 85               (fig-forth-auto680):04587                 FCB     $85
248B 424C4F43         (fig-forth-auto680):04588                 FCC     'BLOC'  ; 'BLOCK'
248F CB               (fig-forth-auto680):04589                 FCB     $CB
2490 2441             (fig-forth-auto680):04590                 FDB     BUFFER-9
2492 17B91930177216C6 (fig-forth-auto680):04591         BLOCK   FDB     DOCOL,OFSET,AT,PLUS,TOR
     1681
249C 23B8177217451772 (fig-forth-auto680):04592                 FDB     PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
     169C1A04174516C6
     1409
24AE 0032             (fig-forth-auto680):04593                 FDB     BLOCK5-*-NATWID
24B0 23C316A31409     (fig-forth-auto680):04594         BLOCK3  FDB     PBUF,ZEQU,ZBRAN
24B6 0012             (fig-forth-auto680):04595                 FDB     BLOCK4-*-NATWID
                      (fig-forth-auto680):04596         *       FDB     DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
24B8 172A169C244A1745 (fig-forth-auto680):04597                 FDB     DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
     169C1845263B17F7
     1A04
24CA 17451772169C1A04 (fig-forth-auto680):04598         BLOCK4  FDB     DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
     174516C616A31409
24DA FFD4             (fig-forth-auto680):04599                 FDB     BLOCK3-*-NATWID
24DC 174523B8178A     (fig-forth-auto680):04600                 FDB     DUP,PREV,STORE
                      (fig-forth-auto680):04601         * BLOCK5        FDB     FROMR,DROP,TWOP
24E2 1690172A1802     (fig-forth-auto680):04602         BLOCK5  FDB     FROMR,DROP,NATP
24E8 1667             (fig-forth-auto680):04603                 FDB     SEMIS
                      (fig-forth-auto680):04604         *
                      (fig-forth-auto680):04605         * ######>> screen 61 <<
                      (fig-forth-auto680):04606         * ======>>  177  <<
                      (fig-forth-auto680):04607         * ( line screen --- buffer C/L)
                      (fig-forth-auto680):04608         * Bring in the sector containing the specified line of the specified screen. 
                      (fig-forth-auto680):04609         * Returns the buffer address and the width of the screen. 
                      (fig-forth-auto680):04610         * Screen number is relative to OFFSET. 
                      (fig-forth-auto680):04611         * The line number may be beyond screen 4,
                      (fig-forth-auto680):04612         * (LINE) will get the appropriate screen.
24EA 86               (fig-forth-auto680):04613                 FCB     $86
24EB 284C494E45       (fig-forth-auto680):04614                 FCC     '(LINE' ; '(LINE)'
24F0 A9               (fig-forth-auto680):04615                 FCB     $A9
24F1 248A             (fig-forth-auto680):04616                 FDB     BLOCK-8
24F3 17B9168113A7     (fig-forth-auto680):04617         PLINE   FDB     DOCOL,TOR,LIT8
24F9 40               (fig-forth-auto680):04618                 FCB     $40
24FA 188223451690188E (fig-forth-auto680):04619                 FDB     BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
     230616C6249216C6
     13A7
250C 40               (fig-forth-auto680):04620                 FCB     $40
250D 1667             (fig-forth-auto680):04621                 FDB     SEMIS
                      (fig-forth-auto680):04622         *
                      (fig-forth-auto680):04623         * ======>>  178  <<
                      (fig-forth-auto680):04624         * ( line screen --- )
                      (fig-forth-auto680):04625         * Print the line of the screen as found by (LINE), suppress trailing BLANKS.
250F 85               (fig-forth-auto680):04626                 FCB     $85
2510 2E4C494E         (fig-forth-auto680):04627                 FCC     '.LIN'  ; '.LINE'
2514 C5               (fig-forth-auto680):04628                 FCB     $C5
2515 24EA             (fig-forth-auto680):04629                 FDB     PLINE-9
2517 17B924F31CDD1CAF (fig-forth-auto680):04630         DLINE   FDB     DOCOL,PLINE,DTRAIL,TYPE
251F 1667             (fig-forth-auto680):04631                 FDB     SEMIS
                      (fig-forth-auto680):04632         *
                      (fig-forth-auto680):04633         * ======>>  179  <<
                      (fig-forth-auto680):04634         * ( n --- )
                      (fig-forth-auto680):04635         * If WARNING is 0, print "MESSAGE #n";
                      (fig-forth-auto680):04636         * otherwise, print line n relative to screen 4,
                      (fig-forth-auto680):04637         * the line number may be negative. 
                      (fig-forth-auto680):04638         * Uses .LINE, but counter-adjusts to be relative to the real drive 0.
2521 87               (fig-forth-auto680):04639                 FCB     $87
2522 4D4553534147     (fig-forth-auto680):04640                 FCC     'MESSAG'        ; 'MESSAGE'
2528 C5               (fig-forth-auto680):04641                 FCB     $C5
2529 250F             (fig-forth-auto680):04642                 FDB     DLINE-8
252B 17B918D817721409 (fig-forth-auto680):04643         MESS    FDB     DOCOL,WARN,AT,ZBRAN
2533 0019             (fig-forth-auto680):04644                 FDB     MESS3-*-NATWID
2535 1A8A1409         (fig-forth-auto680):04645                 FDB     DDUP,ZBRAN
2539 0013             (fig-forth-auto680):04646                 FDB     MESS3-*-NATWID
253B 13A7             (fig-forth-auto680):04647                 FDB     LIT8
253D 04               (fig-forth-auto680):04648                 FCB     4
253E 19301772188E2325 (fig-forth-auto680):04649                 FDB     OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
     1A04251713FA
254C 000B             (fig-forth-auto680):04650                 FDB     MESS4-*-NATWID
254E 1D10             (fig-forth-auto680):04651         MESS3   FDB     PDOTQ
2550 06               (fig-forth-auto680):04652                 FCB     6
2551 657272202320     (fig-forth-auto680):04653                 FCC     'err # '        ; 'err # '
2557 28D6             (fig-forth-auto680):04654                 FDB     DOT
2559 1667             (fig-forth-auto680):04655         MESS4   FDB     SEMIS
                      (fig-forth-auto680):04656         *
                      (fig-forth-auto680):04657         * ======>>  180  <<
                      (fig-forth-auto680):04658         * ( n --- )
                      (fig-forth-auto680):04659         * Begin interpretation of screen (block) n. 
                      (fig-forth-auto680):04660         * See also ARROW, SEMIS, and NULL.
255B 84               (fig-forth-auto680):04661                 FCB     $84
255C 4C4F41           (fig-forth-auto680):04662                 FCC     'LOA'   ; 'LOAD' :      input:scr #
255F C4               (fig-forth-auto680):04663                 FCB     $C4
2560 2521             (fig-forth-auto680):04664                 FDB     MESS-10
2562 17B9190617721681 (fig-forth-auto680):04665         LOAD    FDB     DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
     190F17721681183D
     190F178A
2576 188E23061906178A (fig-forth-auto680):04666                 FDB     BSCR,STAR,BLK,STORE
257E 211D1690190F178A (fig-forth-auto680):04667                 FDB     INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
     16901906178A
258C 1667             (fig-forth-auto680):04668                 FDB     SEMIS
                      (fig-forth-auto680):04669         *
                      (fig-forth-auto680):04670         * ======>>  181  <<
                      (fig-forth-auto680):04671         * ( --- )                                                 P
                      (fig-forth-auto680):04672         * Continue interpreting source code on the next screen.
258E C3               (fig-forth-auto680):04673                 FCB     $C3
258F 2D2D             (fig-forth-auto680):04674                 FCC     '--'    ; '-->'
2591 BE               (fig-forth-auto680):04675                 FCB     $BE
2592 255B             (fig-forth-auto680):04676                 FDB     LOAD-7
2594 17B91BAE183D190F (fig-forth-auto680):04677         ARROW   FDB     DOCOL,QLOAD,ZERO,IN,STORE,BSCR
     178A188E
25A0 19061772171C2335 (fig-forth-auto680):04678                 FDB     BLK,AT,OVER,MOD,SUB,BLK,PSTORE
     1A0419061751
25AE 1667             (fig-forth-auto680):04679                 FDB     SEMIS
                      (fig-forth-auto680):04680                 PAGE
                      (fig-forth-auto680):04681         *
                      (fig-forth-auto680):04682         *
                      (fig-forth-auto680):04683         * ######>> screen 63 <<
                      (fig-forth-auto680):04684         *    The next 4 subroutines are machine dependent, and are
                      (fig-forth-auto680):04685         *    called by words 13 through 16 in the dictionary.
                      (fig-forth-auto680):04686         *
                      (fig-forth-auto680):04687         * ======>>  182  << code for EMIT
                      (fig-forth-auto680):04688         * ( --- ) No parameter stack effect.
                      (fig-forth-auto680):04689         * Interfaces directly with ROM. Expects output character in D (therefore, B).
                      (fig-forth-auto680):04690         * Output using rom CHROUT: redirectable to a printer on Coco.
                      (fig-forth-auto680):04691         * Outputs the character on stack (low byte of 1 bit word/cell).
25B0 3468             (fig-forth-auto680):04692         PEMIT   PSHS    Y,U,DP  ; Save everything important! (For good measure, only.)
25B2 1F98             (fig-forth-auto680):04693                 TFR     B,A     ; Coco ROM wants it in A.
25B4 5F               (fig-forth-auto680):04694                 CLRB
25B5 1F9B             (fig-forth-auto680):04695                 TFR     B,DP    ; Give the ROM its direct page.
25B7 AD9FA002         (fig-forth-auto680):04696                 JSR     [$A002] ; Output the character in A.
25BB 35E8             (fig-forth-auto680):04697                 PULS    Y,U,DP,PC
                      (fig-forth-auto680):04698         * PEMIT STB N   save B
                      (fig-forth-auto680):04699         *       STX     N+1     save X
                      (fig-forth-auto680):04700         *       LDB ACIAC
                      (fig-forth-auto680):04701         *       BITB #2 check ready bit
                      (fig-forth-auto680):04702         *       BEQ     PEMIT+4 if not ready for more data
                      (fig-forth-auto680):04703         *       STA ACIAD
                      (fig-forth-auto680):04704         *       LDX     UP
                      (fig-forth-auto680):04705         *       STB IOSTAT-UORIG,X
                      (fig-forth-auto680):04706         *       LDB N   recover B & X
                      (fig-forth-auto680):04707         *       LDX     N+1
                      (fig-forth-auto680):04708         *       RTS             only A register may change
                      (fig-forth-auto680):04709         *  PEMIT        JMP     $E1D1   for MIKBUG
                      (fig-forth-auto680):04710         *  PEMIT        FCB     $3F,$11,$39     for PROTO
                      (fig-forth-auto680):04711         *  PEMIT        JMP     $D286 for Smoke Signal DOS
                      (fig-forth-auto680):04712         *
                      (fig-forth-auto680):04713         * ======>>  183  << code for KEY
                      (fig-forth-auto680):04714         * ( --- ) No parameter stack effect.
                      (fig-forth-auto680):04715         * Returns character or break flag in D, since this interfaces with Coco ROM.
                      (fig-forth-auto680):04716         * Wait for key from POLCAT on Coco.
                      (fig-forth-auto680):04717         * Returns the character code for the key pressed.
25BD 3468             (fig-forth-auto680):04718         PKEY    PSHS    Y,U,DP  ; Must save everything important for this one.
25BF 86CF             (fig-forth-auto680):04719                 LDA     #$CF    ; a cursor of sorts
25C1 5F               (fig-forth-auto680):04720                 CLRB
25C2 1F9B             (fig-forth-auto680):04721                 TFR     B,DP
     00               (fig-forth-auto680):04722                 SETDP   0
25C4 9E88             (fig-forth-auto680):04723                 LDX     <$88    ; location
25C6 E684             (fig-forth-auto680):04724                 LDB     ,X      ; save glyph
25C8 A784             (fig-forth-auto680):04725                 STA     ,X
25CA AD9FA000         (fig-forth-auto680):04726         PKEYLP  JSR     [$A000]
25CE B7041A           (fig-forth-auto680):04727                 STA     $41A    ; DBG!
25D1 27F7             (fig-forth-auto680):04728                 BEQ     PKEYLP
25D3 FD0418           (fig-forth-auto680):04729                 STD     $418    ; DBG!
25D6 E784             (fig-forth-auto680):04730                 STB     ,X      ; restore
25D8 5F               (fig-forth-auto680):04731         PKEYR   CLRB            ; for the break flag, shares code with PQTER
25D9 8103             (fig-forth-auto680):04732                 CMPA    #3      ; break key
25DB 2601             (fig-forth-auto680):04733                 BNE     PKEYGT
25DD 53               (fig-forth-auto680):04734                 COMB            ; for the break flag
25DE 1E89             (fig-forth-auto680):04735         PKEYGT  EXG     A,B     ; Leave it in D for return.
25E0 35E8             (fig-forth-auto680):04736                 PULS    Y,U,DP,PC       ; Shares exit with PQTER
     7C               (fig-forth-auto680):04737                 SETDP IUPDP
                      (fig-forth-auto680):04738         * PKEY  STB N
                      (fig-forth-auto680):04739         *       STX     N+1
                      (fig-forth-auto680):04740         *       LDB ACIAC
                      (fig-forth-auto680):04741         *       ASRB    ;
                      (fig-forth-auto680):04742         *       BCC     PKEY+4  no incoming data yet
                      (fig-forth-auto680):04743         *       LDA ACIAD
                      (fig-forth-auto680):04744         *       ANDA #$7F       strip parity bit
                      (fig-forth-auto680):04745         *       LDX     UP
                      (fig-forth-auto680):04746         *       STB IOSTAT+1-UORIG,X
                      (fig-forth-auto680):04747         *       LDB N
                      (fig-forth-auto680):04748         *       LDX     N+1
                      (fig-forth-auto680):04749         *       RTS
                      (fig-forth-auto680):04750         *  PKEY JMP     $E1AC   for MIKBUG
                      (fig-forth-auto680):04751         *  PKEY FCB     $3F,$14,$39     for PROTO
                      (fig-forth-auto680):04752         *  PKEY JMP     $D289 for Smoke Signal DOS
                      (fig-forth-auto680):04753         *
                      (fig-forth-auto680):04754         * ######>> screen 64 <<
                      (fig-forth-auto680):04755         * ======>>  184  << code for ?TERMINAL
                      (fig-forth-auto680):04756         * ( --- f ) Should change this to no stack effect.
                      (fig-forth-auto680):04757         * check break key using POLCAT
                      (fig-forth-auto680):04758         * Returns a flag to tell whether the break key was pressed or not.
25E2 3468             (fig-forth-auto680):04759         PQTER   PSHS Y,U,DP
25E4 5F               (fig-forth-auto680):04760                 CLRB
25E5 1F9B             (fig-forth-auto680):04761                 TFR B,DP
25E7 AD9FA000         (fig-forth-auto680):04762                 JSR [$A000]     ; Look but don't wait.
25EB 20EB             (fig-forth-auto680):04763                 BRA PKEYR
                      (fig-forth-auto680):04764         * PQTER LDA ACIAC       Test for 'break'  condition
                      (fig-forth-auto680):04765         *       ANDA #$11       mask framing error bit and
                      (fig-forth-auto680):04766         *                       input buffer full
                      (fig-forth-auto680):04767         *       BEQ     PQTER2
                      (fig-forth-auto680):04768         *       LDA ACIAD       clear input buffer
                      (fig-forth-auto680):04769         *       LDA #01
                      (fig-forth-auto680):04770         * PQTER2        RTS
                      (fig-forth-auto680):04771         
                      (fig-forth-auto680):04772         
                      (fig-forth-auto680):04773                 PAGE
                      (fig-forth-auto680):04774         *
                      (fig-forth-auto680):04775         * ======>>  185  << code for CR
                      (fig-forth-auto680):04776         * ( --- ) No stack effect.
                      (fig-forth-auto680):04777         * Interfaces directly with ROM. 
                      (fig-forth-auto680):04778         * For Coco just output a CR.
                      (fig-forth-auto680):04779         * Also subject to redirection in Coco BASIC ROM.
25ED C60D             (fig-forth-auto680):04780         PCR     LDB #$0D
25EF 20BF             (fig-forth-auto680):04781                 BRA PEMIT       ; Just steal the code.
                      (fig-forth-auto680):04782         * PCR   LDA #$D carriage return
                      (fig-forth-auto680):04783         *       BSR     PEMIT
                      (fig-forth-auto680):04784         *       LDA #$A line feed
                      (fig-forth-auto680):04785         *       BSR     PEMIT
                      (fig-forth-auto680):04786         *       LDA #$7F        rubout
                      (fig-forth-auto680):04787         *       LDX     UP
                      (fig-forth-auto680):04788         *       LDB XDELAY+1-UORIG,X
                      (fig-forth-auto680):04789         * PCR2  DECB    ;
                      (fig-forth-auto680):04790         *       BMI     PQTER2  return if minus
                      (fig-forth-auto680):04791         *       PSHS B  ; save counter
                      (fig-forth-auto680):04792         *       BSR     PEMIT   print RUBOUTs to delay.....
                      (fig-forth-auto680):04793         *       PULS B  ; 
                      (fig-forth-auto680):04794         *       BRA     PCR2    repeat
                      (fig-forth-auto680):04795         
                      (fig-forth-auto680):04796         
                      (fig-forth-auto680):04797                 PAGE
                      (fig-forth-auto680):04798         *
                      (fig-forth-auto680):04799         * ######>> screen 66 <<
                      (fig-forth-auto680):04800         * ======>>  187  <<
                      (fig-forth-auto680):04801         * ( ??? )
                      (fig-forth-auto680):04802         * Query the disk, I suppose.
                      (fig-forth-auto680):04803         * Not sure what the model had in mind for this stub.
25F1 85               (fig-forth-auto680):04804                 FCB     $85
25F2 3F444953         (fig-forth-auto680):04805                 FCC     '?DIS'  ; '?DISC'
25F6 C3               (fig-forth-auto680):04806                 FCB     $C3
25F7 258E             (fig-forth-auto680):04807                 FDB     ARROW-6
25F9 25FB             (fig-forth-auto680):04808         QDISC   FDB     *+NATWID
25FB 7E1228           (fig-forth-auto680):04809                 JMP     NEXT
                      (fig-forth-auto680):04810         *
                      (fig-forth-auto680):04811         * ######>> screen 67 <<
                      (fig-forth-auto680):04812         * ======>>  189  <<
                      (fig-forth-auto680):04813         * ( ??? )
                      (fig-forth-auto680):04814         * Write one block of data to disk.
                      (fig-forth-auto680):04815         * Parameters unspecified in model. Stub in model.
25FE 8B               (fig-forth-auto680):04816                 FCB     $8B
25FF 424C4F434B2D5752 (fig-forth-auto680):04817                 FCC     'BLOCK-WRIT'    ; 'BLOCK-WRITE'
     4954
2609 C5               (fig-forth-auto680):04818                 FCB     $C5
260A 25F1             (fig-forth-auto680):04819                 FDB     QDISC-8
260C 260E             (fig-forth-auto680):04820         BWRITE  FDB     *+NATWID
260E 7E1228           (fig-forth-auto680):04821                 JMP     NEXT
                      (fig-forth-auto680):04822         *
                      (fig-forth-auto680):04823         * ######>> screen 68 <<
                      (fig-forth-auto680):04824         * ======>>  190  <<
                      (fig-forth-auto680):04825         * ( ??? )
                      (fig-forth-auto680):04826         * Read one block of data from disk.
                      (fig-forth-auto680):04827         * Parameters unspecified in model. Stub in model.
2611 8A               (fig-forth-auto680):04828                 FCB     $8A
2612 424C4F434B2D5245 (fig-forth-auto680):04829                 FCC     'BLOCK-REA'     ; 'BLOCK-READ'
     41
261B C4               (fig-forth-auto680):04830                 FCB     $C4
261C 25FE             (fig-forth-auto680):04831                 FDB     BWRITE-14
261E 2620             (fig-forth-auto680):04832         BREAD   FDB     *+NATWID
2620 7E1228           (fig-forth-auto680):04833                 JMP     NEXT
                      (fig-forth-auto680):04834         *
                      (fig-forth-auto680):04835         *The next 3 words are written to create a substitute for disc
                      (fig-forth-auto680):04836         * mass memory,located between $3210 & $3FFF in ram.
                      (fig-forth-auto680):04837         * ======>>  190.1  <<
2623 82               (fig-forth-auto680):04838                 FCB     $82
2624 4C               (fig-forth-auto680):04839                 FCC     'L'     ; 'LO'
2625 CF               (fig-forth-auto680):04840                 FCB     $CF
2626 2611             (fig-forth-auto680):04841                 FDB     BREAD-13
2628 17E9             (fig-forth-auto680):04842         LO      FDB     DOCON
262A 7000             (fig-forth-auto680):04843                 FDB     MEMEND  a system dependent equate at front
                      (fig-forth-auto680):04844         *
                      (fig-forth-auto680):04845         * ======>>  190.2  <<
262C 82               (fig-forth-auto680):04846                 FCB     $82
262D 48               (fig-forth-auto680):04847                 FCC     'H'     ; 'HI'
262E C9               (fig-forth-auto680):04848                 FCB     $C9
262F 2623             (fig-forth-auto680):04849                 FDB     LO-5
2631 17E9             (fig-forth-auto680):04850         HI      FDB     DOCON
2633 7FFF             (fig-forth-auto680):04851                 FDB     MEMTOP  ( $3FFF or $7FFF in this version )
                      (fig-forth-auto680):04852         *
                      (fig-forth-auto680):04853         * ######>> screen 69 <<
                      (fig-forth-auto680):04854         * ======>>  191  <<
                      (fig-forth-auto680):04855         * ( buffer sector f --- )
                      (fig-forth-auto680):04856         * Read or Write the specified (absolute -- ignores OFFSET) sector
                      (fig-forth-auto680):04857         * from or to the specified buffer. 
                      (fig-forth-auto680):04858         * A zero flag specifies write,
                      (fig-forth-auto680):04859         * non-zero specifies read. 
                      (fig-forth-auto680):04860         * Sector is an unsigned integer,
                      (fig-forth-auto680):04861         * buffer is the buffer's address. 
                      (fig-forth-auto680):04862         * Will need to use the CoCo ROM disk routines. 
                      (fig-forth-auto680):04863         * For now, provides a virtual disk in RAM.
2635 83               (fig-forth-auto680):04864                 FCB     $83
2636 522F             (fig-forth-auto680):04865                 FCC     'R/'    ; 'R/W'
2638 D7               (fig-forth-auto680):04866                 FCB     $D7
2639 262C             (fig-forth-auto680):04867                 FDB     HI-5
263B 17B9168118822306 (fig-forth-auto680):04868         RW      FDB     DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
     262816C617452631
     1A351409
264F 000D             (fig-forth-auto680):04869                 FDB     RW2-*-NATWID
2651 1D10             (fig-forth-auto680):04870                 FDB     PDOTQ
2653 08               (fig-forth-auto680):04871                 FCB     8
2654 2052616E6765203F (fig-forth-auto680):04872                 FCC     ' Range ?'      ; ' Range ?'
265C 21D7             (fig-forth-auto680):04873                 FDB     QUIT
265E 16901409         (fig-forth-auto680):04874         RW2     FDB     FROMR,ZBRAN
2662 0002             (fig-forth-auto680):04875                 FDB     RW3-*-NATWID
2664 1736             (fig-forth-auto680):04876                 FDB     SWAP
2666 18821584         (fig-forth-auto680):04877         RW3     FDB     BBUF,CMOVE
266A 1667             (fig-forth-auto680):04878                 FDB     SEMIS
                      (fig-forth-auto680):04879         *
                      (fig-forth-auto680):04880         * From BIF-6809:
                      (fig-forth-auto680):04881         * RW    PSHS Y,U,DP
                      (fig-forth-auto680):04882         *       LDY $C006 control table
                      (fig-forth-auto680):04883         *       LDX #DROFFS+7   ; This is BIF's table of drive sizes.
                      (fig-forth-auto680):04884         *       LDD 2,U
                      (fig-forth-auto680):04885         * RWD   SUBD ,X++ sectors
                      (fig-forth-auto680):04886         *       BHS RWD
                      (fig-forth-auto680):04887         *       BVC RWR table end?
                      (fig-forth-auto680):04888         *       LDD #6
                      (fig-forth-auto680):04889         *       PSHU D
                      (fig-forth-auto680):04890         *       JMP ERROR
                      (fig-forth-auto680):04891         * RWR   ADDD ,--X back one
                      (fig-forth-auto680):04892         *       PSHS X
                      (fig-forth-auto680):04893         *       PSHU D
                      (fig-forth-auto680):04894         *       LDD #18 sectors/track
                      (fig-forth-auto680):04895         *       PSHU D
                      (fig-forth-auto680):04896         *       DOCOL
                      (fig-forth-auto680):04897         *       FDB SLAMOD
                      (fig-forth-auto680):04898         *       FDB XMACH
                      (fig-forth-auto680):04899         *       PULU D
                      (fig-forth-auto680):04900         *       STB 2,Y track
                      (fig-forth-auto680):04901         *       PULU D
                      (fig-forth-auto680):04902         *       INCB
                      (fig-forth-auto680):04903         *       STB 3,Y sector
                      (fig-forth-auto680):04904         *       PULS D table entry
                      (fig-forth-auto680):04905         *       SUBD #DROFFS+7
                      (fig-forth-auto680):04906         *       ASRB drive #
                      (fig-forth-auto680):04907         *       STB 1,Y
                      (fig-forth-auto680):04908         *       LDD 4,U buffer
                      (fig-forth-auto680):04909         *       STD 4,Y
                      (fig-forth-auto680):04910         *       LDB #2 coco READ
                      (fig-forth-auto680):04911         *       LDX ,U 0?
                      (fig-forth-auto680):04912         *       BNE *+3
                      (fig-forth-auto680):04913         *       INCB coco WRITE
                      (fig-forth-auto680):04914         *       STB ,Y op code
                      (fig-forth-auto680):04915         *       CLRA
                      (fig-forth-auto680):04916         *       TFR A,DP
                      (fig-forth-auto680):04917         *       JSR [$C004]     ROM handles timeout
                      (fig-forth-auto680):04918         *       PULS Y,U,DP     if IRQ enabled
                      (fig-forth-auto680):04919         *       LEAU 6,U
                      (fig-forth-auto680):04920         *       LDX $C006
                      (fig-forth-auto680):04921         *       LDB 6,X coco status
                      (fig-forth-auto680):04922         *       BEQ RWE
                      (fig-forth-auto680):04923         *       LDX <UP
                      (fig-forth-auto680):04924         *       LDD #0 no disc
                      (fig-forth-auto680):04925         *       STD UWARN,X
                      (fig-forth-auto680):04926         *       LDD #8
                      (fig-forth-auto680):04927         *       PSHU D
                      (fig-forth-auto680):04928         *       JMP ERROR
                      (fig-forth-auto680):04929         * RWE   NEXT
                      (fig-forth-auto680):04930         *
                      (fig-forth-auto680):04931         * ######>> screen 72 <<
                      (fig-forth-auto680):04932         * ======>>  192  <<
                      (fig-forth-auto680):04933         * ( --- ) compiling                                       P
                      (fig-forth-auto680):04934         * ( --- adr ) interpreting
                      (fig-forth-auto680):04935         * { ' name } input
                      (fig-forth-auto680):04936         * Parse a symbol name from input and search the dictionary for it, per -FIND;
                      (fig-forth-auto680):04937         * compile the address as a literal if compiling,
                      (fig-forth-auto680):04938         * otherwise just push it. 
266C C1               (fig-forth-auto680):04939                 FCB     $C1     immediate
266D A7               (fig-forth-auto680):04940                 FCB     $A7     '       ( tick )
266E 2635             (fig-forth-auto680):04941                 FDB     RW-6
2670 17B91FAD16A3183D (fig-forth-auto680):04942         TICK    FDB     DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
     1B39172A20E2
267E 1667             (fig-forth-auto680):04943                 FDB     SEMIS
                      (fig-forth-auto680):04944         *
                      (fig-forth-auto680):04945         * ======>>  193  <<
                      (fig-forth-auto680):04946         * ( --- ) { FORGET name } input
                      (fig-forth-auto680):04947         * Parse out name of definition to FORGET to, -DFIND it,
                      (fig-forth-auto680):04948         * then lop it and everything that follows out of the dictionary. 
                      (fig-forth-auto680):04949         * In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
2680 86               (fig-forth-auto680):04950                 FCB     $86
2681 464F524745       (fig-forth-auto680):04951                 FCC     'FORGE' ; 'FORGET'
2686 D4               (fig-forth-auto680):04952                 FCB     $D4
2687 266C             (fig-forth-auto680):04953                 FDB     TICK-4
2689 17B9194C1772193E (fig-forth-auto680):04954         FORGET  FDB     DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
     17721A0413A7
2697 18               (fig-forth-auto680):04955                 FCB     $18
2698 1B392670174518E4 (fig-forth-auto680):04956                 FDB     QERR,TICK,DUP,FENCE,AT,LESS,LIT8
     17721A1D13A7
26A6 15               (fig-forth-auto680):04957                 FCB     $15
26A7 1B391745183D189C (fig-forth-auto680):04958                 FDB     QERR,DUP,ZERO,PORIG,GREAT,LIT8
     1A3513A7
26B3 15               (fig-forth-auto680):04959                 FCB     $15
26B4 1B3917451AFD18ED (fig-forth-auto680):04960                 FDB     QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
     178A1AE01772193E
     1772178A
26C8 1667             (fig-forth-auto680):04961                 FDB     SEMIS
                      (fig-forth-auto680):04962         *
                      (fig-forth-auto680):04963         * ######>> screen 73 <<
                      (fig-forth-auto680):04964         * ======>>  194  <<
                      (fig-forth-auto680):04965         *  ( adr --- )                                             C
                      (fig-forth-auto680):04966         * Calculate a back reference from HERE and compile it. 
26CA 84               (fig-forth-auto680):04967                 FCB     $84
26CB 424143           (fig-forth-auto680):04968                 FCC     'BAC'   ; 'BACK'
26CE CB               (fig-forth-auto680):04969                 FCB     $CB
26CF 2680             (fig-forth-auto680):04970                 FDB     FORGET-9
                      (fig-forth-auto680):04971         * BACK  FDB     DOCOL,HERE,SUB,COMMA
26D1 17B919C718021A04 (fig-forth-auto680):04972         BACK    FDB     DOCOL,HERE,NATP,SUB,COMMA
     19E3
26DB 1667             (fig-forth-auto680):04973                 FDB     SEMIS
                      (fig-forth-auto680):04974         *
                      (fig-forth-auto680):04975         * ======>>  195  <<
                      (fig-forth-auto680):04976         * ( --- )   runtime
                      (fig-forth-auto680):04977         * typical use: BEGIN code-loop test UNTIL  
                      (fig-forth-auto680):04978         * typical use: BEGIN code-loop AGAIN  
                      (fig-forth-auto680):04979         * typical use: BEGIN code-loop test WHILE code-true REPEAT  
                      (fig-forth-auto680):04980         * ( --- adr n )  compile time                       P,C
                      (fig-forth-auto680):04981         * Push HERE for BACK reference for general (non-counting) loops,
                      (fig-forth-auto680):04982         * with BEGIN construct flag.
                      (fig-forth-auto680):04983         * A better flag: $4245 (ASCII for 'BE').
26DD C5               (fig-forth-auto680):04984                 FCB     $C5
26DE 42454749         (fig-forth-auto680):04985                 FCC     'BEGI'  ; 'BEGIN'
26E2 CE               (fig-forth-auto680):04986                 FCB     $CE
26E3 26CA             (fig-forth-auto680):04987                 FDB     BACK-7
26E5 17B91B5319C71845 (fig-forth-auto680):04988         BEGIN   FDB     DOCOL,QCOMP,HERE,ONE    ; ONE is a flag for BEGIN loops.
26ED 1667             (fig-forth-auto680):04989                 FDB     SEMIS
                      (fig-forth-auto680):04990         *
                      (fig-forth-auto680):04991         * ======>>  196  <<
                      (fig-forth-auto680):04992         * ( --- )   runtime
                      (fig-forth-auto680):04993         * typical use: test IF code-true ELSE code-false ENDIF 
                      (fig-forth-auto680):04994         * ENDIF is just a sort of intersection piece, 
                      (fig-forth-auto680):04995         * marking where execution resumes after both branches.
                      (fig-forth-auto680):04996         * ( adr n --- ) compile time
                      (fig-forth-auto680):04997         * Check the mark and resolve the IF.
                      (fig-forth-auto680):04998         * A better flag: $4846 (ASCII for 'IF').
26EF C5               (fig-forth-auto680):04999                 FCB     $C5
26F0 454E4449         (fig-forth-auto680):05000                 FCC     'ENDI'  ; 'ENDIF'
26F4 C6               (fig-forth-auto680):05001                 FCB     $C6
26F5 26DD             (fig-forth-auto680):05002                 FDB     BEGIN-8
26F7 17B91B53184D1B80 (fig-forth-auto680):05003         ENDIF   FDB     DOCOL,QCOMP,TWO,QPAIRS,HERE     ; This TWO is a flag for IF.
     19C7
2701 171C18021A041736 (fig-forth-auto680):05004                 FDB     OVER,NATP,SUB,SWAP,STORE
     178A
270B 1667             (fig-forth-auto680):05005                 FDB     SEMIS
                      (fig-forth-auto680):05006         *
                      (fig-forth-auto680):05007         * ======>>  197  <<
                      (fig-forth-auto680):05008         * ( --- )   runtime
                      (fig-forth-auto680):05009         * typical use: test IF code-true ELSE code-false ENDIF 
                      (fig-forth-auto680):05010         * ( adr n --- ) 
                      (fig-forth-auto680):05011         * Alias for ENDIF .
270D C4               (fig-forth-auto680):05012                 FCB     $C4
270E 544845           (fig-forth-auto680):05013                 FCC     'THE'   ; 'THEN'
2711 CE               (fig-forth-auto680):05014                 FCB     $CE
2712 26EF             (fig-forth-auto680):05015                 FDB     ENDIF-8
2714 17B926F7         (fig-forth-auto680):05016         THEN    FDB     DOCOL,ENDIF
2718 1667             (fig-forth-auto680):05017                 FDB     SEMIS
                      (fig-forth-auto680):05018         *
                      (fig-forth-auto680):05019         * ======>>  198  <<
                      (fig-forth-auto680):05020         * ( limit index --- )   runtime
                      (fig-forth-auto680):05021         * typical use: DO code-loop LOOP  
                      (fig-forth-auto680):05022         * typical use: DO code-loop increment +LOOP
                      (fig-forth-auto680):05023         * Counted loop, index is initial value of index.
                      (fig-forth-auto680):05024         * Will loop until index equals (positive going)
                      (fig-forth-auto680):05025         * or passes (negative going) limit.
                      (fig-forth-auto680):05026         *  ( --- adr n )  compile time                        P,C
                      (fig-forth-auto680):05027         * Compile (DO), push HERE for BACK reference,
                      (fig-forth-auto680):05028         * and push DO control construct flag.
                      (fig-forth-auto680):05029         * A better flag: $444F (ASCII for 'DO').
271A C2               (fig-forth-auto680):05030                 FCB     $C2
271B 44               (fig-forth-auto680):05031                 FCC     'D'     ; 'DO'
271C CF               (fig-forth-auto680):05032                 FCB     $CF
271D 270D             (fig-forth-auto680):05033                 FDB     THEN-7
271F 17B91BC7145319C7 (fig-forth-auto680):05034         DO      FDB     DOCOL,COMPIL,XDO,HERE,THREE     ; THREE is a flag for DO loops.
     1855
2729 1667             (fig-forth-auto680):05035                 FDB     SEMIS
                      (fig-forth-auto680):05036         *
                      (fig-forth-auto680):05037         * ======>>  199  <<
                      (fig-forth-auto680):05038         * ( --- )   runtime
                      (fig-forth-auto680):05039         * typical use: DO code-loop LOOP  
                      (fig-forth-auto680):05040         * Increments the index by one and branches back to beginning of loop.
                      (fig-forth-auto680):05041         * Will loop until index equals limit.
                      (fig-forth-auto680):05042         * ( adr n --- )  compile time                        P,C
                      (fig-forth-auto680):05043         * Check the mark and compile (LOOP), fill in BACK reference.
                      (fig-forth-auto680):05044         * A better flag: $444F (ASCII for 'DO').
272B C4               (fig-forth-auto680):05045                 FCB     $C4
272C 4C4F4F           (fig-forth-auto680):05046                 FCC     'LOO'   ; 'LOOP'
272F D0               (fig-forth-auto680):05047                 FCB     $D0
2730 271A             (fig-forth-auto680):05048                 FDB     DO-5
2732 17B918551B801BC7 (fig-forth-auto680):05049         LOOP    FDB     DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK    ; THREE for DO loops.
     141D26D1
273E 1667             (fig-forth-auto680):05050                 FDB     SEMIS
                      (fig-forth-auto680):05051         *
                      (fig-forth-auto680):05052         * ======>>  200  <<
                      (fig-forth-auto680):05053         * ( n --- )   runtime
                      (fig-forth-auto680):05054         * typical use: DO code-loop increment +LOOP
                      (fig-forth-auto680):05055         * Increments the index by n and branches back to beginning of loop.
                      (fig-forth-auto680):05056         * Will loop until index equals (positive going)
                      (fig-forth-auto680):05057         * or passes (negative going) limit.
                      (fig-forth-auto680):05058         * ( adr n --- )  compile time                       P,C
                      (fig-forth-auto680):05059         * Check the mark and compile (+LOOP), fill in BACK reference.
                      (fig-forth-auto680):05060         * A better flag: $444F (ASCII for 'DO').
2740 C5               (fig-forth-auto680):05061                 FCB     $C5
2741 2B4C4F4F         (fig-forth-auto680):05062                 FCC     '+LOO'  ; '+LOOP'
2745 D0               (fig-forth-auto680):05063                 FCB     $D0
2746 272B             (fig-forth-auto680):05064                 FDB     LOOP-7
2748 17B918551B801BC7 (fig-forth-auto680):05065         PLOOP   FDB     DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK   ; THREE for DO loops.
     143C26D1
2754 1667             (fig-forth-auto680):05066                 FDB     SEMIS
                      (fig-forth-auto680):05067         *
                      (fig-forth-auto680):05068         * ======>>  201  <<
                      (fig-forth-auto680):05069         * ( n --- )   runtime
                      (fig-forth-auto680):05070         * typical use: BEGIN code-loop test UNTIL  
                      (fig-forth-auto680):05071         * Will loop until UNTIL tests true.
                      (fig-forth-auto680):05072         * ( adr n --- )  compile time                      P,C
                      (fig-forth-auto680):05073         * Check the mark and compile (0BRANCH), fill in BACK reference.
                      (fig-forth-auto680):05074         * A better flag: $4245 (ASCII for 'BE').
2756 C5               (fig-forth-auto680):05075                 FCB     $C5
2757 554E5449         (fig-forth-auto680):05076                 FCC     'UNTI'  ; 'UNTIL' :     ( same as END )
275B CC               (fig-forth-auto680):05077                 FCB     $CC
275C 2740             (fig-forth-auto680):05078                 FDB     PLOOP-8
275E 17B918451B801BC7 (fig-forth-auto680):05079         UNTIL   FDB     DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK      ; ONE for BEGIN loops.
     140926D1
276A 1667             (fig-forth-auto680):05080                 FDB     SEMIS
                      (fig-forth-auto680):05081         *
                      (fig-forth-auto680):05082         * ######>> screen 74 <<
                      (fig-forth-auto680):05083         * ======>>  202  <<
                      (fig-forth-auto680):05084         * ( n --- )   runtime
                      (fig-forth-auto680):05085         * typical use: BEGIN code-loop test END  
                      (fig-forth-auto680):05086         * ( adr n --- ) 
                      (fig-forth-auto680):05087         * Alias for UNTIL .
276C C3               (fig-forth-auto680):05088                 FCB     $C3
276D 454E             (fig-forth-auto680):05089                 FCC     'EN'    ; 'END'
276F C4               (fig-forth-auto680):05090                 FCB     $C4
2770 2756             (fig-forth-auto680):05091                 FDB     UNTIL-8
2772 17B9275E         (fig-forth-auto680):05092         END     FDB     DOCOL,UNTIL
2776 1667             (fig-forth-auto680):05093                 FDB     SEMIS
                      (fig-forth-auto680):05094         *
                      (fig-forth-auto680):05095         * ======>>  203  <<
                      (fig-forth-auto680):05096         * ( --- )   runtime
                      (fig-forth-auto680):05097         * typical use: BEGIN code-loop AGAIN  
                      (fig-forth-auto680):05098         * Will loop forever 
                      (fig-forth-auto680):05099         * (or until something uses R> DROP to force the current definition to die,
                      (fig-forth-auto680):05100         *  or perhaps ABORT or ERROR or some such other drastic means stops things).
                      (fig-forth-auto680):05101         * ( adr n --- )  compile time                      P,C
                      (fig-forth-auto680):05102         * Check the mark and compile (0BRANCH), fill in BACK reference.
                      (fig-forth-auto680):05103         * A better flag: $4245 (ASCII for 'BE').
2778 C5               (fig-forth-auto680):05104                 FCB     $C5
2779 41474149         (fig-forth-auto680):05105                 FCC     'AGAI'  ; 'AGAIN'
277D CE               (fig-forth-auto680):05106                 FCB     $CE
277E 276C             (fig-forth-auto680):05107                 FDB     END-6
2780 17B918451B801BC7 (fig-forth-auto680):05108         AGAIN   FDB     DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK       ; ONE for BEGIN loops.
     13FA26D1
278C 1667             (fig-forth-auto680):05109                 FDB     SEMIS
                      (fig-forth-auto680):05110         *
                      (fig-forth-auto680):05111         * ======>>  204  <<
                      (fig-forth-auto680):05112         * ( --- )   runtime
                      (fig-forth-auto680):05113         * typical use: BEGIN code-loop test WHILE code-true REPEAT  
                      (fig-forth-auto680):05114         * Will loop until WHILE tests false, skipping code-true on end.
                      (fig-forth-auto680):05115         * REPEAT marks where execution resumes after the WHILE find a false flag.
                      (fig-forth-auto680):05116         * ( aadr1 n1 adr2 n2 --- )   compile time         P,C
                      (fig-forth-auto680):05117         * Check the marks for WHILE and BEGIN,
                      (fig-forth-auto680):05118         * compile BRANCH and BACK fill adr1 reference,
                      (fig-forth-auto680):05119         * FILL-IN 0BRANCH reference at adr2.
                      (fig-forth-auto680):05120         * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
278E C6               (fig-forth-auto680):05121                 FCB     $C6
278F 5245504541       (fig-forth-auto680):05122                 FCC     'REPEA' ; 'REPEAT'
2794 D4               (fig-forth-auto680):05123                 FCB     $D4
2795 2778             (fig-forth-auto680):05124                 FDB     AGAIN-8
2797 17B9168116812780 (fig-forth-auto680):05125         REPEAT  FDB     DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
     16901690
27A3 184D1A0426F7     (fig-forth-auto680):05126                 FDB     TWO,SUB,ENDIF   ; TWO is for IF, 4 is for WHILE.
27A9 1667             (fig-forth-auto680):05127                 FDB     SEMIS
                      (fig-forth-auto680):05128         *
                      (fig-forth-auto680):05129         * ======>>  205  <<
                      (fig-forth-auto680):05130         * ( n --- )   runtime
                      (fig-forth-auto680):05131         * typical use: test IF code-true ELSE code-false ENDIF 
                      (fig-forth-auto680):05132         * Will pass execution to the true part on a true flag 
                      (fig-forth-auto680):05133         * and to the false part on a false flag.
                      (fig-forth-auto680):05134         * ( --- adr n )  compile time                       P,C
                      (fig-forth-auto680):05135         * Compile a 0BRANCH and dummy offset
                      (fig-forth-auto680):05136         * and push IF reference to fill in and
                      (fig-forth-auto680):05137         * IF control construct flag.
                      (fig-forth-auto680):05138         * A better flag: $4946 (ASCII for 'IF').
27AB C2               (fig-forth-auto680):05139                 FCB     $C2
27AC 49               (fig-forth-auto680):05140                 FCC     'I'     ; 'IF'
27AD C6               (fig-forth-auto680):05141                 FCB     $C6
27AE 278E             (fig-forth-auto680):05142                 FDB     REPEAT-9
27B0 17B91BC7140919C7 (fig-forth-auto680):05143         IF      FDB     DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO  ; TWO is a flag for IF.
     183D19E3184D
27BE 1667             (fig-forth-auto680):05144                 FDB     SEMIS
                      (fig-forth-auto680):05145         *
                      (fig-forth-auto680):05146         * ======>>  206  <<
                      (fig-forth-auto680):05147         * ( --- )   runtime
                      (fig-forth-auto680):05148         * typical use: test IF code-true ELSE code-false ENDIF 
                      (fig-forth-auto680):05149         * ELSE is just a sort of intersection piece, 
                      (fig-forth-auto680):05150         * marking where execution resumes on a false branch.
                      (fig-forth-auto680):05151         * ( adr1 n --- adr2 n )  compile time         P,C
                      (fig-forth-auto680):05152         * Check the marks,
                      (fig-forth-auto680):05153         * compile BRANCH with dummy offset,
                      (fig-forth-auto680):05154         * resolve IF reference,
                      (fig-forth-auto680):05155         * and leave reference to BRANCH for ELSE.
                      (fig-forth-auto680):05156         * A better flag: $4946 (ASCII for 'IF').
27C0 C4               (fig-forth-auto680):05157                 FCB     $C4
27C1 454C53           (fig-forth-auto680):05158                 FCC     'ELS'   ; 'ELSE'
27C4 C5               (fig-forth-auto680):05159                 FCB     $C5
27C5 27AB             (fig-forth-auto680):05160                 FDB     IF-5
27C7 17B9184D1B801BC7 (fig-forth-auto680):05161         ELSE    FDB     DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
     13FA19C7
27D3 183D19E31736184D (fig-forth-auto680):05162                 FDB     ZERO,COMMA,SWAP,TWO,ENDIF,TWO   ; TWO is a flag for IF.
     26F7184D
27DF 1667             (fig-forth-auto680):05163                 FDB     SEMIS
                      (fig-forth-auto680):05164         *
                      (fig-forth-auto680):05165         * ======>>  207  <<
                      (fig-forth-auto680):05166         * ( n --- )   runtime
                      (fig-forth-auto680):05167         * typical use: BEGIN code-loop test WHILE code-true REPEAT  
                      (fig-forth-auto680):05168         * Will loop until WHILE tests false, skipping code-true on end.
                      (fig-forth-auto680):05169         * ( --- adr n ) compile time                        P,C
                      (fig-forth-auto680):05170         * Compile 0BRANCH with dummy offset (using IF),
                      (fig-forth-auto680):05171         * push WHILE reference.
                      (fig-forth-auto680):05172         * BEGIN flag will sit underneath this.
                      (fig-forth-auto680):05173         * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
27E1 C5               (fig-forth-auto680):05174                 FCB     $C5
27E2 5748494C         (fig-forth-auto680):05175                 FCC     'WHIL'  ; 'WHILE'
27E6 C5               (fig-forth-auto680):05176                 FCB     $C5
27E7 27C0             (fig-forth-auto680):05177                 FDB     ELSE-7
27E9 17B927B019B8     (fig-forth-auto680):05178         WHILE   FDB     DOCOL,IF,TWOP   ; TWO is a flag for IF, 4 is for WHILE.
27EF 1667             (fig-forth-auto680):05179                 FDB     SEMIS
                      (fig-forth-auto680):05180         *
                      (fig-forth-auto680):05181         * ######>> screen 75 <<
                      (fig-forth-auto680):05182         * ======>>  208  <<
                      (fig-forth-auto680):05183         * ( count --- )
                      (fig-forth-auto680):05184         * EMIT count spaces, for non-zero, non-negative counts.
27F1 86               (fig-forth-auto680):05185                 FCB     $86
27F2 5350414345       (fig-forth-auto680):05186                 FCC     'SPACE' ; 'SPACES'
27F7 D3               (fig-forth-auto680):05187                 FCB     $D3
27F8 27E1             (fig-forth-auto680):05188                 FDB     WHILE-8
27FA 17B9183D1A771A8A (fig-forth-auto680):05189         SPACES  FDB     DOCOL,ZERO,MAX,DDUP,ZBRAN
     1409
2804 000A             (fig-forth-auto680):05190                 FDB     SPACE3-*-NATWID
2806 183D1453         (fig-forth-auto680):05191                 FDB     ZERO,XDO
280A 1A57141D         (fig-forth-auto680):05192         SPACE2  FDB     SPACE,XLOOP
280E FFFA             (fig-forth-auto680):05193                 FDB     SPACE2-*-NATWID
2810 1667             (fig-forth-auto680):05194         SPACE3  FDB     SEMIS
                      (fig-forth-auto680):05195         *
                      (fig-forth-auto680):05196         * ======>>  209  <<
                      (fig-forth-auto680):05197         * ( --- )
                      (fig-forth-auto680):05198         * Initialize HLD for converting a double integer. 
                      (fig-forth-auto680):05199         * Stores the PAD address in HLD.
2812 82               (fig-forth-auto680):05200                 FCB     $82
2813 3C               (fig-forth-auto680):05201                 FCC     '<'     ; '<#'
2814 A3               (fig-forth-auto680):05202                 FCB     $A3
2815 27F1             (fig-forth-auto680):05203                 FDB     SPACES-9
2817 17B91EAA1994178A (fig-forth-auto680):05204         BDIGS   FDB     DOCOL,PAD,HLD,STORE
281F 1667             (fig-forth-auto680):05205                 FDB     SEMIS
                      (fig-forth-auto680):05206         *
                      (fig-forth-auto680):05207         * ======>>  210  <<
                      (fig-forth-auto680):05208         * ( d --- string length )
                      (fig-forth-auto680):05209         * Terminate numeric conversion,
                      (fig-forth-auto680):05210         * drop the number being converted,
                      (fig-forth-auto680):05211         * leave the address of the conversion string and the length, ready for TYPE.
2821 82               (fig-forth-auto680):05212                 FCB     $82
2822 23               (fig-forth-auto680):05213                 FCC     '#'     ; '#>'
2823 BE               (fig-forth-auto680):05214                 FCB     $BE
2824 2812             (fig-forth-auto680):05215                 FDB     BDIGS-5
2826 17B9172A172A1994 (fig-forth-auto680):05216         EDIGS   FDB     DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
     17721EAA171C1A04
2836 1667             (fig-forth-auto680):05217                 FDB     SEMIS
                      (fig-forth-auto680):05218         *
                      (fig-forth-auto680):05219         * ======>>  211  <<
                      (fig-forth-auto680):05220         * ( n d --- d )
                      (fig-forth-auto680):05221         * Put sign of n (as a flag) at the head of the conversion string.
                      (fig-forth-auto680):05222         * Drop the sign flag.
2838 84               (fig-forth-auto680):05223                 FCB     $84
2839 534947           (fig-forth-auto680):05224                 FCC     'SIG'   ; 'SIGN'
283C CE               (fig-forth-auto680):05225                 FCB     $CE
283D 2821             (fig-forth-auto680):05226                 FDB     EDIGS-5
283F 17B91A4316B51409 (fig-forth-auto680):05227         SIGN    FDB     DOCOL,ROT,ZLESS,ZBRAN
2847 0005             (fig-forth-auto680):05228                 FDB     SIGN2-*-NATWID
2849 13A7             (fig-forth-auto680):05229                 FDB     LIT8
284B 2D               (fig-forth-auto680):05230                 FCC     "-"     
284C 1E92             (fig-forth-auto680):05231                 FDB     HOLD
284E 1667             (fig-forth-auto680):05232         SIGN2   FDB     SEMIS
                      (fig-forth-auto680):05233         *
                      (fig-forth-auto680):05234         * ======>>  212  <<
                      (fig-forth-auto680):05235         * ( d --- d/base )
                      (fig-forth-auto680):05236         * Generate next most significant digit in the conversion BASE,
                      (fig-forth-auto680):05237         * putting the digit at the head of the conversion string.
2850 81               (fig-forth-auto680):05238                 FCB     $81     #
2851 A3               (fig-forth-auto680):05239                 FCB     $A3
2852 2838             (fig-forth-auto680):05240                 FDB     SIGN-7
2854 17B9196317722368 (fig-forth-auto680):05241         DIG     FDB     DOCOL,BASE,AT,MSMOD,ROT,LIT8
     1A4313A7
2860 09               (fig-forth-auto680):05242                 FCB     9
2861 171C1A1D1409     (fig-forth-auto680):05243                 FDB     OVER,LESS,ZBRAN
2867 0005             (fig-forth-auto680):05244                 FDB     DIG2-*-NATWID
2869 13A7             (fig-forth-auto680):05245                 FDB     LIT8
286B 07               (fig-forth-auto680):05246                 FCB     7
286C 16C6             (fig-forth-auto680):05247                 FDB     PLUS
286E 13A7             (fig-forth-auto680):05248         DIG2    FDB     LIT8
2870 30               (fig-forth-auto680):05249                 FCC     "0"     ascii zero
2871 16C61E92         (fig-forth-auto680):05250                 FDB     PLUS,HOLD
2875 1667             (fig-forth-auto680):05251                 FDB     SEMIS
                      (fig-forth-auto680):05252         *
                      (fig-forth-auto680):05253         * ======>>  213  <<
                      (fig-forth-auto680):05254         * ( d --- dzero )
                      (fig-forth-auto680):05255         * Convert d to a numeric string using # until the result is zero.
                      (fig-forth-auto680):05256         * Leave the double result on the stack for #> to drop.
2877 82               (fig-forth-auto680):05257                 FCB     $82
2878 23               (fig-forth-auto680):05258                 FCC     '#'     ; '#S'
2879 D3               (fig-forth-auto680):05259                 FCB     $D3
287A 2850             (fig-forth-auto680):05260                 FDB     DIG-4
287C 17B9             (fig-forth-auto680):05261         DIGS    FDB     DOCOL
287E 2854171C171C161E (fig-forth-auto680):05262         DIGS2   FDB     DIG,OVER,OVER,OR,ZEQU,ZBRAN
     16A31409
288A FFF2             (fig-forth-auto680):05263                 FDB     DIGS2-*-NATWID
288C 1667             (fig-forth-auto680):05264                 FDB     SEMIS
                      (fig-forth-auto680):05265         *
                      (fig-forth-auto680):05266         * ######>> screen 76 <<
                      (fig-forth-auto680):05267         * ======>>  214  <<
                      (fig-forth-auto680):05268         * ( n width --- )
                      (fig-forth-auto680):05269         * Print n on the output device in the current conversion base,
                      (fig-forth-auto680):05270         * with sign,
                      (fig-forth-auto680):05271         * right aligned in a field at least width wide.
288E 82               (fig-forth-auto680):05272                 FCB     $82
288F 2E               (fig-forth-auto680):05273                 FCC     '.'     ; '.R'
2890 D2               (fig-forth-auto680):05274                 FCB     $D2
2891 2877             (fig-forth-auto680):05275                 FDB     DIGS-5
2893 17B9168122F81690 (fig-forth-auto680):05276         DOTR    FDB     DOCOL,TOR,STOD,FROMR,DDOTR
     28A5
289D 1667             (fig-forth-auto680):05277                 FDB     SEMIS
                      (fig-forth-auto680):05278         *
                      (fig-forth-auto680):05279         * ======>>  215  <<
                      (fig-forth-auto680):05280         * ( d width --- )
                      (fig-forth-auto680):05281         * Print d on the output device in the current conversion base,
                      (fig-forth-auto680):05282         * with sign,
                      (fig-forth-auto680):05283         * right aligned in a field at least width wide.
289F 83               (fig-forth-auto680):05284                 FCB     $83
28A0 442E             (fig-forth-auto680):05285                 FCC     'D.'    ; 'D.R'
28A2 D2               (fig-forth-auto680):05286                 FCB     $D2
28A3 288E             (fig-forth-auto680):05287                 FDB     DOTR-5
28A5 17B916811736171C (fig-forth-auto680):05288         DDOTR   FDB     DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
     23992817287C283F
28B5 28261690171C1A04 (fig-forth-auto680):05289                 FDB     EDIGS,FROMR,OVER,SUB,SPACES,TYPE
     27FA1CAF
28C1 1667             (fig-forth-auto680):05290                 FDB     SEMIS
                      (fig-forth-auto680):05291         *
                      (fig-forth-auto680):05292         * ======>>  216  <<
                      (fig-forth-auto680):05293         * D.      ( d --- )
                      (fig-forth-auto680):05294         * Print d on the output device in the current conversion base,
                      (fig-forth-auto680):05295         * with sign,
                      (fig-forth-auto680):05296         * in free format with trailing space.
28C3 82               (fig-forth-auto680):05297                 FCB     $82
28C4 44               (fig-forth-auto680):05298                 FCC     'D'     ; 'D.'
28C5 AE               (fig-forth-auto680):05299                 FCB     $AE
28C6 289F             (fig-forth-auto680):05300                 FDB     DDOTR-6
28C8 17B9183D28A51A57 (fig-forth-auto680):05301         DDOT    FDB     DOCOL,ZERO,DDOTR,SPACE
28D0 1667             (fig-forth-auto680):05302                 FDB     SEMIS
                      (fig-forth-auto680):05303         *
                      (fig-forth-auto680):05304         * ======>>  217  <<
                      (fig-forth-auto680):05305         * ( n --- )
                      (fig-forth-auto680):05306         * Print n on the output device in the current conversion base,
                      (fig-forth-auto680):05307         * with sign,
                      (fig-forth-auto680):05308         * in free format with trailing space.
28D2 81               (fig-forth-auto680):05309                 FCB     $81     .
28D3 AE               (fig-forth-auto680):05310                 FCB     $AE
28D4 28C3             (fig-forth-auto680):05311                 FDB     DDOT-5
28D6 17B922F828C8     (fig-forth-auto680):05312         DOT     FDB     DOCOL,STOD,DDOT
28DC 1667             (fig-forth-auto680):05313                 FDB     SEMIS
                      (fig-forth-auto680):05314         *
                      (fig-forth-auto680):05315         * ======>>  218  <<
                      (fig-forth-auto680):05316         * ( adr --- )
                      (fig-forth-auto680):05317         * Print signed word at adr, per DOT.
28DE 81               (fig-forth-auto680):05318                 FCB     $81     ?
28DF BF               (fig-forth-auto680):05319                 FCB     $BF
28E0 28D2             (fig-forth-auto680):05320                 FDB     DOT-4
28E2 17B9177228D6     (fig-forth-auto680):05321         QUEST   FDB     DOCOL,AT,DOT
28E8 1667             (fig-forth-auto680):05322                 FDB     SEMIS
                      (fig-forth-auto680):05323         *
                      (fig-forth-auto680):05324         * ######>> screen 77 <<
                      (fig-forth-auto680):05325         * ======>>  219  <<
                      (fig-forth-auto680):05326         * ( n --- )
                      (fig-forth-auto680):05327         * Print out screen n as a field of ASCII,
                      (fig-forth-auto680):05328         * with line numbers in decimal.
                      (fig-forth-auto680):05329         * Needs a console more than 70 characters wide.
28EA 84               (fig-forth-auto680):05330                 FCB     $84
28EB 4C4953           (fig-forth-auto680):05331                 FCC     'LIS'   ; 'LIST'
28EE D4               (fig-forth-auto680):05332                 FCB     $D4
28EF 28DE             (fig-forth-auto680):05333                 FDB     QUEST-4
28F1 17B91C2515771745 (fig-forth-auto680):05334         LIST    FDB     DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
     1923178A1D10
28FF 06               (fig-forth-auto680):05335                 FCB     6
2900 534352202320     (fig-forth-auto680):05336                 FCC     "SCR # "
2906 28D613A7         (fig-forth-auto680):05337                 FDB     DOT,LIT8
290A 10               (fig-forth-auto680):05338                 FCB     $10
290B 183D1453         (fig-forth-auto680):05339                 FDB     ZERO,XDO
290F 157714651855     (fig-forth-auto680):05340         LIST2   FDB     CR,I,THREE
2915 28931A5714651923 (fig-forth-auto680):05341                 FDB     DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
     17722517141D
2923 FFEA             (fig-forth-auto680):05342                 FDB     LIST2-*-NATWID
2925 1577             (fig-forth-auto680):05343                 FDB     CR
2927 1667             (fig-forth-auto680):05344                 FDB     SEMIS
                      (fig-forth-auto680):05345         *
                      (fig-forth-auto680):05346         * ======>>  220  <<
                      (fig-forth-auto680):05347         * ( start end --- )
                      (fig-forth-auto680):05348         * Print comment lines (line 0, and line 1 if C/L < 41) of screens
                      (fig-forth-auto680):05349         * from start to end.
                      (fig-forth-auto680):05350         * Needs a console more than 70 characters wide.
2929 85               (fig-forth-auto680):05351                 FCB     $85
292A 494E4445         (fig-forth-auto680):05352                 FCC     'INDE'  ; 'INDEX'
292E D8               (fig-forth-auto680):05353                 FCB     $D8
292F 28EA             (fig-forth-auto680):05354                 FDB     LIST-7
2931 17B9157719AB1736 (fig-forth-auto680):05355         INDEX   FDB     DOCOL,CR,ONEP,SWAP,XDO
     1453
293B 157714651855     (fig-forth-auto680):05356         INDEX2  FDB     CR,I,THREE
2941 28931A57183D1465 (fig-forth-auto680):05357                 FDB     DOTR,SPACE,ZERO,I,DLINE
     2517
294B 156A1409         (fig-forth-auto680):05358                 FDB     QTERM,ZBRAN
294F 0002             (fig-forth-auto680):05359                 FDB     INDEX3-*-NATWID
2951 1675             (fig-forth-auto680):05360                 FDB     LEAVE
2953 141D             (fig-forth-auto680):05361         INDEX3  FDB     XLOOP
2955 FFE4             (fig-forth-auto680):05362                 FDB     INDEX2-*-NATWID
2957 1667             (fig-forth-auto680):05363                 FDB     SEMIS
                      (fig-forth-auto680):05364         *
                      (fig-forth-auto680):05365         * ======>>  221  <<
                      (fig-forth-auto680):05366         * ( n --- )
                      (fig-forth-auto680):05367         * List a printer page full of screens.
                      (fig-forth-auto680):05368         * Line and screen number are in current base.
                      (fig-forth-auto680):05369         * Needs a console more than 70 characters wide.
2959 85               (fig-forth-auto680):05370                 FCB     $85
295A 54524941         (fig-forth-auto680):05371                 FCC     'TRIA'  ; 'TRIAD'
295E C4               (fig-forth-auto680):05372                 FCB     $C4
295F 2929             (fig-forth-auto680):05373                 FDB     INDEX-8
2961 17B9185523251855 (fig-forth-auto680):05374         TRIAD   FDB     DOCOL,THREE,SLASH,THREE,STAR
     2306
296B 1855171C16C61736 (fig-forth-auto680):05375                 FDB     THREE,OVER,PLUS,SWAP,XDO
     1453
2975 15771465         (fig-forth-auto680):05376         TRIAD2  FDB     CR,I
2979 28F1156A1409     (fig-forth-auto680):05377                 FDB     LIST,QTERM,ZBRAN
297F 0002             (fig-forth-auto680):05378                 FDB     TRIAD3-*-NATWID
2981 1675             (fig-forth-auto680):05379                 FDB     LEAVE
2983 141D             (fig-forth-auto680):05380         TRIAD3  FDB     XLOOP
2985 FFEE             (fig-forth-auto680):05381                 FDB     TRIAD2-*-NATWID
2987 157713A7         (fig-forth-auto680):05382                 FDB     CR,LIT8
298B 0F               (fig-forth-auto680):05383                 FCB     $0F
298C 252B1577         (fig-forth-auto680):05384                 FDB     MESS,CR
2990 1667             (fig-forth-auto680):05385                 FDB     SEMIS
                      (fig-forth-auto680):05386         *
                      (fig-forth-auto680):05387         * ######>> screen 78 <<
                      (fig-forth-auto680):05388         * ======>>  222  <<
                      (fig-forth-auto680):05389         * ( --- )
                      (fig-forth-auto680):05390         * Alphabetically list the definitions in the current vocabulary.
                      (fig-forth-auto680):05391         * Expects to output to printer, not TRS80 Color Computer screen.
2992 85               (fig-forth-auto680):05392                 FCB     $85
2993 564C4953         (fig-forth-auto680):05393                 FCC     'VLIS'  ; 'VLIST'
2997 D4               (fig-forth-auto680):05394                 FCB     $D4
2998 2959             (fig-forth-auto680):05395                 FDB     TRIAD-8
299A 17B913A7         (fig-forth-auto680):05396         VLIST   FDB     DOCOL,LIT8
299E 80               (fig-forth-auto680):05397                 FCB     $80
299F 1919178A193E1772 (fig-forth-auto680):05398                 FDB     OUT,STORE,CONTXT,AT,AT
     1772
29A9 1919177219A21772 (fig-forth-auto680):05399         VLIST1  FDB     OUT,AT,COLUMS,AT,LIT8
     13A7
29B3 20               (fig-forth-auto680):05400                 FCB     32
29B4 1A041A351409     (fig-forth-auto680):05401                 FDB     SUB,GREAT,ZBRAN
29BA 0008             (fig-forth-auto680):05402                 FDB     VLIST2-*-NATWID
29BC 1577183D1919178A (fig-forth-auto680):05403                 FDB     CR,ZERO,OUT,STORE
29C4 174520301A571A57 (fig-forth-auto680):05404         VLIST2  FDB     DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
     1B121AE01772
29D2 174516A3156A161E (fig-forth-auto680):05405                 FDB     DUP,ZEQU,QTERM,OR,ZBRAN
     1409
29DC FFCB             (fig-forth-auto680):05406                 FDB     VLIST1-*-NATWID
29DE 172A             (fig-forth-auto680):05407                 FDB     DROP
29E0 1667             (fig-forth-auto680):05408                 FDB     SEMIS
                      (fig-forth-auto680):05409         *
                      (fig-forth-auto680):05410         * Need some utility stuff that isn't in the fig FORTH:
                      (fig-forth-auto680):05411         * ( c --- )
                      (fig-forth-auto680):05412         * Emit dot if c is less than blank, else emit c
29E2 85               (fig-forth-auto680):05413                 FCB     $85
29E3 42454D49         (fig-forth-auto680):05414                 FCC     'BEMI'  ; 'BEMIT'
29E7 D4               (fig-forth-auto680):05415                 FCB     $D4     ; 'T'
29E8 2992             (fig-forth-auto680):05416                 FDB     VLIST-8
29EA 17B9             (fig-forth-auto680):05417         BEMIT   FDB     DOCOL
29EC 1745185E1A1D1409 (fig-forth-auto680):05418                 FDB     DUP,BL,LESS,ZBRAN
29F4 0005             (fig-forth-auto680):05419                 FDB     BEMITO-*-NATWID
29F6 172A13A7         (fig-forth-auto680):05420                 FDB     DROP,LIT8
29FA 2E               (fig-forth-auto680):05421                 FCB     $2e     ; '.'
29FB 1542             (fig-forth-auto680):05422         BEMITO  FDB     EMIT
29FD 1667             (fig-forth-auto680):05423                 FDB     SEMIS
                      (fig-forth-auto680):05424         *
                      (fig-forth-auto680):05425         * ( n width --- )
                      (fig-forth-auto680):05426         * Output n in hexadecimal field width.
29FF 83               (fig-forth-auto680):05427                 FCB     $83
2A00 582E             (fig-forth-auto680):05428                 FCC     'X.'    ; 'X.R'
2A02 D2               (fig-forth-auto680):05429                 FCB     $D2     ; 'R'
2A03 29E2             (fig-forth-auto680):05430                 FDB     BEMIT-8
2A05 17B9             (fig-forth-auto680):05431         XDOTR   FDB     DOCOL
2A07 1963177216811C10 (fig-forth-auto680):05432                 FDB     BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
     289316901963178A
2A17 1667             (fig-forth-auto680):05433                 FDB     SEMIS
                      (fig-forth-auto680):05434         *
                      (fig-forth-auto680):05435         * ( adr --- )
                      (fig-forth-auto680):05436         * Dump a line of 4 bytes in memory, in hex and as characters.
2A19 85               (fig-forth-auto680):05437                 FCB     $85
2A1A 424C494E         (fig-forth-auto680):05438                 FCC     'BLIN'  ; 'BLINE'
2A1E C5               (fig-forth-auto680):05439                 FCB     $C5     ; 'E'
2A1F 29FF             (fig-forth-auto680):05440                 FDB     XDOTR-6
2A21 17B9             (fig-forth-auto680):05441         BLINE   FDB     DOCOL
2A23 174513A7         (fig-forth-auto680):05442                 FDB     DUP,LIT8
2A27 04               (fig-forth-auto680):05443                 FCB     4
2A28 16C6171C1453     (fig-forth-auto680):05444                 FDB     PLUS,OVER,XDO
2A2E 1465177E18552A05 (fig-forth-auto680):05445         BLINEX  FDB     I,CAT,THREE,XDOTR,XLOOP
     141D
2A38 FFF4             (fig-forth-auto680):05446                 FDB     BLINEX-*-NATWID
2A3A 1A571A57         (fig-forth-auto680):05447                 FDB     SPACE,SPACE
2A3E 174513A7         (fig-forth-auto680):05448                 FDB     DUP,LIT8
2A42 04               (fig-forth-auto680):05449                 FCB     4
2A43 17361453         (fig-forth-auto680):05450                 FDB     SWAP,XDO
2A47 1465177E29EA141D (fig-forth-auto680):05451         BLINEC  FDB     I,CAT,BEMIT,XLOOP
2A4F FFF6             (fig-forth-auto680):05452                 FDB     BLINEC-*-NATWID
2A51 1667             (fig-forth-auto680):05453                 FDB     SEMIS
                      (fig-forth-auto680):05454         *
                      (fig-forth-auto680):05455         * ( start end --- )
                      (fig-forth-auto680):05456         * Dump 4 byte lines from start to end.
2A53 85               (fig-forth-auto680):05457                 FCB     $85
2A54 4244554D         (fig-forth-auto680):05458                 FCC     'BDUM'  ; 'BDUMP'
2A58 D0               (fig-forth-auto680):05459                 FCB     $D0     ; '5'
2A59 2A19             (fig-forth-auto680):05460                 FDB     BLINE-8
2A5B 17B9             (fig-forth-auto680):05461         BDUMP   FDB     DOCOL
2A5D 1453             (fig-forth-auto680):05462                 FDB     XDO
2A5F 146513A7         (fig-forth-auto680):05463         BDUMPL  FDB     I,LIT8
2A63 04               (fig-forth-auto680):05464                 FCB     4
2A64 2A0513A7         (fig-forth-auto680):05465                 FDB     XDOTR,LIT8
2A68 3A               (fig-forth-auto680):05466                 FCB     $3A
2A69 15421A57         (fig-forth-auto680):05467                 FDB     EMIT,SPACE
2A6D 14652A21157713A7 (fig-forth-auto680):05468                 FDB     I,BLINE,CR,LIT8
2A75 04               (fig-forth-auto680):05469                 FCB     4
2A76 143C             (fig-forth-auto680):05470                 FDB     XPLOOP
2A78 FFE5             (fig-forth-auto680):05471                 FDB     BDUMPL-*-NATWID
2A7A 1667             (fig-forth-auto680):05472                 FDB     SEMIS
                      (fig-forth-auto680):05473         *
                      (fig-forth-auto680):05474         * ======>>  XX  <<
                      (fig-forth-auto680):05475         * ( --- )
                      (fig-forth-auto680):05476         * Mostly for place holding (fig Forth).
2A7C 84               (fig-forth-auto680):05477                 FCB     $84
2A7D 4E4F4F           (fig-forth-auto680):05478                 FCC     'NOO'   ; 'NOOP'
2A80 D0               (fig-forth-auto680):05479                 FCB     $D0
2A81 2A53             (fig-forth-auto680):05480                 FDB     BDUMP-8
2A83 1228             (fig-forth-auto680):05481         NOOP    FDB     NEXT    a useful no-op
2A85 0000000000000000 (fig-forth-auto680):05482         ZZZZ    FDB     0,0,0,0,0,0,0,0 end of rom program
     0000000000000000
                      (fig-forth-auto680):05483         
                      (fig-forth-auto680):05484                 PAGE
                      (fig-forth-auto680):05485         *  These things, up through the lable 'REND', are overwritten
                      (fig-forth-auto680):05486         *  at time of cold load and should have the same contents
                      (fig-forth-auto680):05487         *  as shown here:
                      (fig-forth-auto680):05488         *
                      (fig-forth-auto680):05489         * This can be moved whereever the bottom of the
                      (fig-forth-auto680):05490         * user's dictionary is going to be put.
                      (fig-forth-auto680):05491         *
2A95 C5               (fig-forth-auto680):05492                 FCB     $C5     immediate
2A96 464F5254         (fig-forth-auto680):05493                 FCC     'FORT'  ; 'FORTH'
2A9A C8               (fig-forth-auto680):05494                 FCB     $C8
2A9B 2A7C             (fig-forth-auto680):05495                 FDB     NOOP-7
2A9D 1C8621A181A02AC5 (fig-forth-auto680):05496         FORTH   FDB     DODOES,DOVOC,$81A0,TASK-7
2AA5 0000             (fig-forth-auto680):05497                 FDB     0
                      (fig-forth-auto680):05498         *
2AA7 28432920466F7274 (fig-forth-auto680):05499                 FCC     "(C) Forth Interest Group, 1979"
     6820496E74657265
     73742047726F7570
     2C2031393739
                      (fig-forth-auto680):05500         
2AC5 84               (fig-forth-auto680):05501                 FCB     $84
2AC6 544153           (fig-forth-auto680):05502                 FCC     'TAS'   ; 'TASK'
2AC9 CB               (fig-forth-auto680):05503                 FCB     $CB
2ACA 2A95             (fig-forth-auto680):05504                 FDB     FORTH-8
2ACC 17B91667         (fig-forth-auto680):05505         TASK    FDB     DOCOL,SEMIS
                      (fig-forth-auto680):05506         * 
     2AD0             (fig-forth-auto680):05507         REND    EQU     *       ( first empty location in dictionary )
                      (fig-forth-auto680):05508         
                      (fig-forth-auto680):05509         
                      (fig-forth-auto680):05510         
                      (fig-forth-auto680):05511         
                      (fig-forth-auto680):05512         
                      (fig-forth-auto680):05513         
                      (fig-forth-auto680):05514         
                      (fig-forth-auto680):05515                 PAGE
                      (fig-forth-auto680):05516                 OPT     L
                      (fig-forth-auto680):05517                 END