--- /dev/null
+ (fig-forth-auto680):00001 OPT PRT
+ (fig-forth-auto680):00002
+ (fig-forth-auto680):00003 * fig-FORTH FOR 6809
+ (fig-forth-auto680):00004 * ASSEMBLY SOURCE LISTING
+ (fig-forth-auto680):00005
+ (fig-forth-auto680):00006 * RELEASE 0
+ (fig-forth-auto680):00007 * JAN 2019
+ (fig-forth-auto680):00008 * WITH COMPILER SECURITY
+ (fig-forth-auto680):00009 * AND VARIABLE LENGTH NAMES
+ (fig-forth-auto680):00010 *
+ (fig-forth-auto680):00011 * Adapted by Joel Matthew Rees
+ (fig-forth-auto680):00012 * from fig-FORTH for 6800 by Dave Lion, et. al.
+ (fig-forth-auto680):00013
+ (fig-forth-auto680):00014 * This free/libre/open source publication is provided
+ (fig-forth-auto680):00015 * through the courtesy of:
+ (fig-forth-auto680):00016 * FORTH
+ (fig-forth-auto680):00017 * INTEREST
+ (fig-forth-auto680):00018 * GROUP
+ (fig-forth-auto680):00019 * fig
+ (fig-forth-auto680):00020 * and other interested parties.
+ (fig-forth-auto680):00021
+ (fig-forth-auto680):00022 * Ancient address:
+ (fig-forth-auto680):00023 * P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
+ (fig-forth-auto680):00024 * URL: http://www.forth.org
+ (fig-forth-auto680):00025 * Further distribution must include this notice.
+ (fig-forth-auto680):00026 PAGE
+ (fig-forth-auto680):00027 NAM Copyright: FORTH Interest Group, original authors, and Joel Matthew Rees
+ (fig-forth-auto680):00028 OPT NOG,PAG
+ (fig-forth-auto680):00029 * filename fig-forth-auto6809opt.asm
+ (fig-forth-auto680):00030 * === FORTH-6809 {date} {time}
+ (fig-forth-auto680):00031
+ (fig-forth-auto680):00032
+ (fig-forth-auto680):00033 * Permission is hereby granted, free of charge, to any person obtaining a copy
+ (fig-forth-auto680):00034 * of this software and associated documentation files (the "Software"), to deal
+ (fig-forth-auto680):00035 * in the Software without restriction, including without limitation the rights
+ (fig-forth-auto680):00036 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+ (fig-forth-auto680):00037 * copies of the Software, and to permit persons to whom the Software is
+ (fig-forth-auto680):00038 * furnished to do so, subject to the following conditions:
+ (fig-forth-auto680):00039 *
+ (fig-forth-auto680):00040 * The above copyright notice and this permission notice shall be included in
+ (fig-forth-auto680):00041 * all copies or substantial portions of the Software.
+ (fig-forth-auto680):00042
+ (fig-forth-auto680):00043 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ (fig-forth-auto680):00044 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ (fig-forth-auto680):00045 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+ (fig-forth-auto680):00046 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ (fig-forth-auto680):00047 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+ (fig-forth-auto680):00048 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+ (fig-forth-auto680):00049 * THE SOFTWARE.
+ (fig-forth-auto680):00050 *
+ (fig-forth-auto680):00051 * "Associated documentation" for this declaration of license
+ (fig-forth-auto680):00052 * shall be interpreted to include only the comments in this file,
+ (fig-forth-auto680):00053 * or, if the code is split into multiple files,
+ (fig-forth-auto680):00054 * all files containing the complete source.
+ (fig-forth-auto680):00055 *
+ (fig-forth-auto680):00056 * This is the MIT model license, as published by the Open Source Consortium,
+ (fig-forth-auto680):00057 * with associated documentation defined.
+ (fig-forth-auto680):00058 * It was chosen to reflect the spirit of the original
+ (fig-forth-auto680):00059 * terms of use, which used archaic legal terminology.
+ (fig-forth-auto680):00060 *
+ (fig-forth-auto680):00061
+ (fig-forth-auto680):00062 * Authors of the 6800 model:
+ (fig-forth-auto680):00063 * === Primary: Dave Lion,
+ (fig-forth-auto680):00064 * === with help from
+ (fig-forth-auto680):00065 * === Bob Smith,
+ (fig-forth-auto680):00066 * === LaFarr Stuart,
+ (fig-forth-auto680):00067 * === The Forth Interest Group
+ (fig-forth-auto680):00068 * === PO Box 1105
+ (fig-forth-auto680):00069 * === San Carlos, CA 94070
+ (fig-forth-auto680):00070 * === and
+ (fig-forth-auto680):00071 * === Unbounded Computing
+ (fig-forth-auto680):00072 * === 1134-K Aster Ave.
+ (fig-forth-auto680):00073 * === Sunnyvale, CA 94086
+ (fig-forth-auto680):00074 *
+ 0002 (fig-forth-auto680):00075 NATWID EQU 2 ; bytes per natural integer/pointer
+ (fig-forth-auto680):00076 * The original version was developed on an AMI EVK 300 PROTO
+ (fig-forth-auto680):00077 * system using an ACIA for the I/O.
+ (fig-forth-auto680):00078 * This version is developed targeting the Tandy Color Computer.
+ (fig-forth-auto680):00079
+ (fig-forth-auto680):00080 * All terminal 1/0
+ (fig-forth-auto680):00081 * is done in three subroutines:
+ (fig-forth-auto680):00082 * PEMIT ( word # 182 )
+ (fig-forth-auto680):00083 * PKEY ( 183 )
+ (fig-forth-auto680):00084 * PQTERM ( 184 )
+ (fig-forth-auto680):00085 *
+ (fig-forth-auto680):00086 * The FORTH words for disc related I/O follow the model
+ (fig-forth-auto680):00087 * of the FORTH Interest Group, but have not yet been
+ (fig-forth-auto680):00088 * tested using a real disc.
+ (fig-forth-auto680):00089 *
+ (fig-forth-auto680):00090 * Addresses in the 6800 implementation reflect the fact that,
+ (fig-forth-auto680):00091 * on the development system, it was convenient to
+ (fig-forth-auto680):00092 * write-protect memory at hex 1000, and leave the first
+ (fig-forth-auto680):00093 * 4K bytes write-enabled. As a consequence, code from
+ (fig-forth-auto680):00094 * location $1000 to lable ZZZZ could be put in ROM.
+ (fig-forth-auto680):00095 * Minor deviations from the model were made in the
+ (fig-forth-auto680):00096 * initialization and words ?STACK and FORGET
+ (fig-forth-auto680):00097 * in order to do this.
+ (fig-forth-auto680):00098 * Those deviations will be altered in this
+ (fig-forth-auto680):00099 * implementation for the 6809 -- Color Computer.
+ (fig-forth-auto680):00100 *
+ (fig-forth-auto680):00101
+ (fig-forth-auto680):00102 *
+ 7FFF (fig-forth-auto680):00103 MEMT32 EQU $7FFF absolute end of all ram
+ 3FFF (fig-forth-auto680):00104 MEMT16 EQU $3FFF
+ 7FFF (fig-forth-auto680):00105 MEMTOP EQU MEMT32 ; tentative guess
+ FBCE (fig-forth-auto680):00106 ACIAC EQU $FBCE the ACIA control address and
+ FBCF (fig-forth-auto680):00107 ACIAD EQU ACIAC+1 data address for PROTO
+ (fig-forth-auto680):00108 PAGE
+ (fig-forth-auto680):00109 * MEMORY MAP for this 16K|32K system:
+ (fig-forth-auto680):00110 * ( delineated so that systems with 4k byte write-
+ (fig-forth-auto680):00111 * protected segments can write protect FORTH )
+ (fig-forth-auto680):00112 *
+ (fig-forth-auto680):00113 * addr. contents pointer init by
+ (fig-forth-auto680):00114 * **** ******************************* ******* ******
+ (fig-forth-auto680):00115 * 2nd through 4th per-user tables
+ (fig-forth-auto680):00116 * 4000|7D00
+ 0100 (fig-forth-auto680):00117 USERSZ EQU 256 ; (Addressable by DP)
+ 0001 (fig-forth-auto680):00118 USER16 EQU 1 ; We can change these for ROMPACK or 64K.
+ 0004 (fig-forth-auto680):00119 USER32 EQU 4
+ 0004 (fig-forth-auto680):00120 USERCT EQU USER32
+ 3F00 (fig-forth-auto680):00121 IUP16 EQU MEMT16+1-USER16*USERSZ
+ 7C00 (fig-forth-auto680):00122 IUP32 EQU MEMT32+1-USER32*USERSZ
+ 7C00 (fig-forth-auto680):00123 IUP EQU IUP32
+ 007C (fig-forth-auto680):00124 IUPDP EQU IUP/256
+ (fig-forth-auto680):00125 * user tables of variables
+ (fig-forth-auto680):00126 * registers & pointers for the virtual machine
+ (fig-forth-auto680):00127 * scratch area used by various words
+ (fig-forth-auto680):00128 * 3F00|7C00 <== UP (DICTPT)
+ (fig-forth-auto680):00129 * 3EFF|7BFF HI
+ (fig-forth-auto680):00130 * substitute for disc mass memory
+ 0003 (fig-forth-auto680):00131 RAMSCR EQU 3
+ 0400 (fig-forth-auto680):00132 SCRSZ EQU 1024
+ (fig-forth-auto680):00133 * 3300|7000 LO,MEMEND
+ 3300 (fig-forth-auto680):00134 RAMD16 EQU IUP16-RAMSCR*SCRSZ
+ 7000 (fig-forth-auto680):00135 RAMD32 EQU IUP32-RAMSCR*SCRSZ
+ 7000 (fig-forth-auto680):00136 RAMDSK EQU RAMD32
+ 3300 (fig-forth-auto680):00137 MEME16 EQU RAMD16
+ 7000 (fig-forth-auto680):00138 MEME32 EQU RAMD32
+ 7000 (fig-forth-auto680):00139 MEMEND EQU MEME32
+ (fig-forth-auto680):00140 * 32FF|6FFF
+ (fig-forth-auto680):00141 * 4 buffer sectors of VIRTUAL MEMORY
+ 0004 (fig-forth-auto680):00142 NBLK EQU 4 ; # of disc buffer blocks for virtual memory
+ (fig-forth-auto680):00143 * Should NBLK be SCRSZ/SECTSZ?
+ (fig-forth-auto680):00144 * each block is SECTSZ+SECTRL bytes in size,
+ (fig-forth-auto680):00145 * holding SECTSZ characters
+ 0100 (fig-forth-auto680):00146 SECTSZ EQU 256
+ 0008 (fig-forth-auto680):00147 SECTRL EQU 8
+ 0420 (fig-forth-auto680):00148 BUFSZ EQU (SECTSZ+SECTRL)*NBLK
+ (fig-forth-auto680):00149 * 2EE0|6BE0 FIRST
+ 2EE0 (fig-forth-auto680):00150 BUFB16 EQU MEME16-BUFSZ
+ 6BE0 (fig-forth-auto680):00151 BUFB32 EQU MEME32-BUFSZ
+ 6BE0 (fig-forth-auto680):00152 BUFBAS EQU BUFB32
+ (fig-forth-auto680):00153 * "end" of "usable ram" -- in 16K
+ (fig-forth-auto680):00154 * 2EE0|6BE0 <== RP RINIT
+ 2EE0 (fig-forth-auto680):00155 IRP16 EQU BUFB16
+ 6BE0 (fig-forth-auto680):00156 IRP32 EQU BUFB32
+ 6BE0 (fig-forth-auto680):00157 IRP EQU IRP32
+ (fig-forth-auto680):00158 * RETURN STACK
+ (fig-forth-auto680):00159 * (64|112 levels nesting)
+ 0080 (fig-forth-auto680):00160 RSTK16 EQU 128
+ 00E0 (fig-forth-auto680):00161 RSTK32 EQU 224
+ (fig-forth-auto680):00162 * (2E60|6B00)
+ 2E60 (fig-forth-auto680):00163 SFTB16 EQU IRP16-RSTK16
+ 6B00 (fig-forth-auto680):00164 SFTB32 EQU IRP32-RSTK32
+ 6B00 (fig-forth-auto680):00165 SFTBND EQU SFTB32
+ (fig-forth-auto680):00166 * INPUT LINE BUFFER
+ (fig-forth-auto680):00167 * holds up to 256 characters
+ (fig-forth-auto680):00168 * and is scanned upward by IN
+ (fig-forth-auto680):00169 * starting at TIB
+ 0100 (fig-forth-auto680):00170 TIBSZ EQU 256
+ (fig-forth-auto680):00171 * 2D60|6A00
+ 2D60 (fig-forth-auto680):00172 ITIB16 EQU SFTB16-TIBSZ
+ 6A00 (fig-forth-auto680):00173 ITIB32 EQU SFTB32-TIBSZ
+ 6A00 (fig-forth-auto680):00174 ITIB EQU ITIB32
+ (fig-forth-auto680):00175 * 2D60|6A00 <== IN TIB
+ 2D60 (fig-forth-auto680):00176 ISP16 EQU ITIB16
+ 6A00 (fig-forth-auto680):00177 ISP32 EQU ITIB32
+ 6A00 (fig-forth-auto680):00178 ISP EQU ISP32
+ (fig-forth-auto680):00179 * 2D60|6A00 <== SP SP0,SINIT
+ (fig-forth-auto680):00180 * DATA STACK
+ (fig-forth-auto680):00181 * | grows downward from 2A60|6A00
+ (fig-forth-auto680):00182 * v
+ (fig-forth-auto680):00183 * - -
+ (fig-forth-auto680):00184 * |
+ (fig-forth-auto680):00185 * I DICTIONARY grows upward
+ (fig-forth-auto680):00186 *
+ (fig-forth-auto680):00187 * ???? end of ram-dictionary. <== DICTPT DPINIT
+ (fig-forth-auto680):00188 * "TASK"
+ (fig-forth-auto680):00189 *
+ (fig-forth-auto680):00190 * ???? "FORTH" ( a word ) <=, <== CONTEXT
+ (fig-forth-auto680):00191 * `==== CURRENT
+ (fig-forth-auto680):00192 * start of ram-dictionary.
+ (fig-forth-auto680):00193 *
+ (fig-forth-auto680):00194 * >>>>>> memory from here up must be in RAM area <<<<<<
+ (fig-forth-auto680):00195 *
+ (fig-forth-auto680):00196 * ????
+ (fig-forth-auto680):00197 * 6k of romable "FORTH" <== IP ABORT
+ (fig-forth-auto680):00198 * <== W
+ (fig-forth-auto680):00199 * the VIRTUAL FORTH MACHINE
+ (fig-forth-auto680):00200 *
+ (fig-forth-auto680):00201 * 1208 initialization tables
+ (fig-forth-auto680):00202 * 1204 <<< WARM START ENTRY >>>
+ (fig-forth-auto680):00203 * 1200 <<< COLD START ENTRY >>>
+ (fig-forth-auto680):00204 * 1200 lowest address used by FORTH
+ (fig-forth-auto680):00205 *
+ 1200 (fig-forth-auto680):00206 CODEBG EQU $1200
+ (fig-forth-auto680):00207 * CODEBG EQU $3000
+ (fig-forth-auto680):00208 *
+ (fig-forth-auto680):00209 * >>>>>> memory from here down left alone <<<<<<
+ (fig-forth-auto680):00210 * >>>>>> so we can safely call ROM routines <<<<<<
+ (fig-forth-auto680):00211 *
+ (fig-forth-auto680):00212 * 0000
+ (fig-forth-auto680):00213 PAGE
+ (fig-forth-auto680):00214 ***
+ (fig-forth-auto680):00215 *
+ (fig-forth-auto680):00216 * CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
+ (fig-forth-auto680):00217 *
+ (fig-forth-auto680):00218 * IP (hardware Y) points to the current instruction ( pre-increment mode )
+ (fig-forth-auto680):00219 * RP (hardware S) points to last return address pushedin return stack
+ (fig-forth-auto680):00220 * SP (hardware U) points to last byte pushed in data stack
+ (fig-forth-auto680):00221 *
+ (fig-forth-auto680):00222 * Y must be IP when NEXT is entered (if using the inner loop).
+ (fig-forth-auto680):00223 *
+ (fig-forth-auto680):00224 * When A and B hold one 16 bit FORTH data word,
+ (fig-forth-auto680):00225 * A contains the high byte, B, the low byte.
+ (fig-forth-auto680):00226 *
+ (fig-forth-auto680):00227 * UP (hardware DP) is the base of per-task ("user") variables.
+ (fig-forth-auto680):00228 * (Be careful of the stray semantics of "user".)
+ (fig-forth-auto680):00229 *
+ (fig-forth-auto680):00230 * W (hardware X) is the pointer to the "code field" address of native CPU
+ (fig-forth-auto680):00231 * machine code to be executed for the definition of the dictionary word
+ (fig-forth-auto680):00232 * to be executed/currently executing.
+ (fig-forth-auto680):00233 * The following natural integer (word) begins any "parameter section"
+ (fig-forth-auto680):00234 * (body) -- similar to a "this" pointer, but not the same.
+ (fig-forth-auto680):00235 * It may be native CPU machine code, or it may be a global variable,
+ (fig-forth-auto680):00236 * or it may be a list of Forth definition words (addresses).
+ (fig-forth-auto680):00237 *
+ (fig-forth-auto680):00238 * ======
+ (fig-forth-auto680):00239 * This implementation uses the native subroutine architecture
+ (fig-forth-auto680):00240 * rather than a postponed-push call that the 6800 model VM uses
+ (fig-forth-auto680):00241 * to save code and time in leaf routines.
+ (fig-forth-auto680):00242 *
+ (fig-forth-auto680):00243 * This should allow directly calling many of the Forth words
+ (fig-forth-auto680):00244 * from assembly language code.
+ (fig-forth-auto680):00245 * (Be aware of the need for a valid W in some cases.)
+ (fig-forth-auto680):00246 * It won't allow mixing assembly language directly into Forth word lists.
+ (fig-forth-auto680):00247 * ======
+ (fig-forth-auto680):00248 *
+ (fig-forth-auto680):00249 * boolean flags:
+ (fig-forth-auto680):00250 * 0 is false, anything else is true.
+ (fig-forth-auto680):00251 * Most places in this model that set a boolean flag set true as 1.
+ (fig-forth-auto680):00252 * This is in contrast to many models that set a boolean flag as -1.
+ (fig-forth-auto680):00253 *
+ (fig-forth-auto680):00254 ***
+ (fig-forth-auto680):00255
+ (fig-forth-auto680):00256 PAGE
+ (fig-forth-auto680):00257 * This system is shown with one user (task),
+ (fig-forth-auto680):00258 * but additional users (tasks) may be added
+ (fig-forth-auto680):00259 * by allocating additional user tables:
+ (fig-forth-auto680):00260 *
+ (fig-forth-auto680):00261 ORG IUP
+7C00 (fig-forth-auto680):00262 UBASE RMB USERSZ
+7D00 (fig-forth-auto680):00263 UBASEX RMB USERSZ data table for extra users
+ (fig-forth-auto680):00264 *
+ (fig-forth-auto680):00265 * Some of this stuff gets initialized during
+ (fig-forth-auto680):00266 * COLD start and WARM start:
+ (fig-forth-auto680):00267 * [ names correspond to FORTH words of similar (no X) name ]
+ (fig-forth-auto680):00268 *
+ (fig-forth-auto680):00269 ORG IUP
+ 7C00 (fig-forth-auto680):00270 UORIG EQU *
+ (fig-forth-auto680):00271 * A few useful VM variables
+ (fig-forth-auto680):00272 * Will be removed when they are no longer needed.
+ (fig-forth-auto680):00273 * All are replaced by 6809 registers.
+ (fig-forth-auto680):00274
+7C00 (fig-forth-auto680):00275 N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
+ (fig-forth-auto680):00276 * SP@,SWAP,DOES>,COLD
+ (fig-forth-auto680):00277
+ (fig-forth-auto680):00278
+ (fig-forth-auto680):00279 * These locations are used by the TRACE routine :
+ (fig-forth-auto680):00280
+7C0A (fig-forth-auto680):00281 TRLIM RMB 1 the count for tracing without user intervention
+7C0B (fig-forth-auto680):00282 TRACEM RMB 1 non-zero = trace mode
+7C0C (fig-forth-auto680):00283 BRKPT RMB 2 the breakpoint address at which
+ (fig-forth-auto680):00284 * the program will go into trace mode
+7C0E (fig-forth-auto680):00285 VECT RMB 2 vector to machine code
+ (fig-forth-auto680):00286 * (only needed if the TRACE routine is resident)
+ (fig-forth-auto680):00287
+ (fig-forth-auto680):00288
+ (fig-forth-auto680):00289 * Registers used by the FORTH virtual machine:
+ (fig-forth-auto680):00290 * Starting at $OOFO:
+ (fig-forth-auto680):00291
+ (fig-forth-auto680):00292
+7C10 (fig-forth-auto680):00293 W RMB 2 the instruction register points to 6800 code
+ (fig-forth-auto680):00294 * This is not exactly accurate. Points to the definiton body,
+ (fig-forth-auto680):00295 * which is native CPU machine code when it is native CPU machine code.
+7C12 (fig-forth-auto680):00296 IP RMB 2 the instruction pointer points to pointer to 6800 code
+7C14 (fig-forth-auto680):00297 RP RMB 2 the return stack pointer
+7C16 (fig-forth-auto680):00298 UP RMB 2 the pointer to base of current user's 'USER' table
+ (fig-forth-auto680):00299 * ( altered during multi-tasking )
+ (fig-forth-auto680):00300 *
+ (fig-forth-auto680):00301 *UORIG RMB 6 3 reserved variables
+7C18 (fig-forth-auto680):00302 RMB 6 3 reserved variables
+7C1E (fig-forth-auto680):00303 XSPZER RMB 2 initial top of data stack for this user
+7C20 (fig-forth-auto680):00304 XRZERO RMB 2 initial top of return stack
+7C22 (fig-forth-auto680):00305 XTIB RMB 2 start of terminal input buffer
+7C24 (fig-forth-auto680):00306 XWIDTH RMB 2 name field width
+7C26 (fig-forth-auto680):00307 XWARN RMB 2 warning message mode (0 = no disc)
+7C28 (fig-forth-auto680):00308 XFENCE RMB 2 fence for FORGET
+7C2A (fig-forth-auto680):00309 XDICTP RMB 2 dictionary pointer
+7C2C (fig-forth-auto680):00310 XVOCL RMB 2 vocabulary linking
+7C2E (fig-forth-auto680):00311 XBLK RMB 2 disc block being accessed
+7C30 (fig-forth-auto680):00312 XIN RMB 2 scan pointer into the block
+7C32 (fig-forth-auto680):00313 XOUT RMB 2 cursor position
+7C34 (fig-forth-auto680):00314 XSCR RMB 2 disc screen being accessed ( O=terminal )
+7C36 (fig-forth-auto680):00315 XOFSET RMB 2 disc sector offset for multi-disc
+7C38 (fig-forth-auto680):00316 XCONT RMB 2 last word in primary search vocabulary
+7C3A (fig-forth-auto680):00317 XCURR RMB 2 last word in extensible vocabulary
+7C3C (fig-forth-auto680):00318 XSTATE RMB 2 flag for 'interpret' or 'compile' modes
+7C3E (fig-forth-auto680):00319 XBASE RMB 2 number base for I/O numeric conversion
+7C40 (fig-forth-auto680):00320 XDPL RMB 2 decimal point place
+7C42 (fig-forth-auto680):00321 XFLD RMB 2
+7C44 (fig-forth-auto680):00322 XCSP RMB 2 current stack position, for compile checks
+7C46 (fig-forth-auto680):00323 XRNUM RMB 2
+7C48 (fig-forth-auto680):00324 XHLD RMB 2
+7C4A (fig-forth-auto680):00325 XDELAY RMB 2 carriage return delay count
+7C4C (fig-forth-auto680):00326 XCOLUM RMB 2 carriage width
+7C4E (fig-forth-auto680):00327 IOSTAT RMB 2 last acia status from write/read
+7C50 (fig-forth-auto680):00328 RMB 2 ( 4 spares! )
+7C52 (fig-forth-auto680):00329 RMB 2
+7C54 (fig-forth-auto680):00330 RMB 2
+7C56 (fig-forth-auto680):00331 RMB 2
+ (fig-forth-auto680):00332
+ (fig-forth-auto680):00333
+ (fig-forth-auto680):00334
+ (fig-forth-auto680):00335
+ (fig-forth-auto680):00336 *
+ (fig-forth-auto680):00337 *
+ (fig-forth-auto680):00338 * end of user table, start of common system variables
+ (fig-forth-auto680):00339 *
+ (fig-forth-auto680):00340 *
+ (fig-forth-auto680):00341 *
+7C58 (fig-forth-auto680):00342 XUSE RMB 2
+7C5A (fig-forth-auto680):00343 XPREV RMB 2
+7C5C (fig-forth-auto680):00344 RMB 4 ( spares )
+ (fig-forth-auto680):00345
+ (fig-forth-auto680):00346 PAGE
+ (fig-forth-auto680):00347 * The FORTH program ( address $1200 to about $27FF ) will be written
+ (fig-forth-auto680):00348 * so that it can be in a ROM, or write-protected if desired,
+ (fig-forth-auto680):00349 * but right now we're just getting it running.
+ (fig-forth-auto680):00350 ORG CODEBG
+ (fig-forth-auto680):00351
+ (fig-forth-auto680):00352 * ######>> screen 3 <<
+ (fig-forth-auto680):00353 *
+ (fig-forth-auto680):00354 ***************************
+ (fig-forth-auto680):00355 ** C O L D E N T R Y **
+ (fig-forth-auto680):00356 ***************************
+1200 12 (fig-forth-auto680):00357 ORIG NOP
+ (fig-forth-auto680):00358 * JMP CENT
+1201 171029 (fig-forth-auto680):00359 LBSR CENT
+ (fig-forth-auto680):00360 ***************************
+ (fig-forth-auto680):00361 ** W A R M E N T R Y **
+ (fig-forth-auto680):00362 ***************************
+1204 12 (fig-forth-auto680):00363 NOP
+ (fig-forth-auto680):00364 * JMP WENT warm-start code, keeps current dictionary intact
+1205 171062 (fig-forth-auto680):00365 LBSR WENT warm-start code, keeps current dictionary intact
+ 7C (fig-forth-auto680):00366 SETDP IUPDP
+ (fig-forth-auto680):00367
+ (fig-forth-auto680):00368 *
+ (fig-forth-auto680):00369 ******* startup parmeters **************************
+ (fig-forth-auto680):00370 *
+1208 68090000 (fig-forth-auto680):00371 FDB $6809,0000 cpu & revision
+120C 0000 (fig-forth-auto680):00372 FDB 0 topmost word in FORTH vocabulary
+ (fig-forth-auto680):00373 * BACKSP FDB $7F backspace character for editing
+120E 0008 (fig-forth-auto680):00374 BACKSP FDB $08 backspace character for editing
+1210 7C00 (fig-forth-auto680):00375 UPINIT FDB UORIG initial user area
+ (fig-forth-auto680):00376 * UPINIT FDB UORIG initial user area
+1212 6A00 (fig-forth-auto680):00377 SINIT FDB ISP ; initial top of data stack
+ (fig-forth-auto680):00378 * SINIT FDB ORIG-$D0 initial top of data stack
+1214 6BE0 (fig-forth-auto680):00379 RINIT FDB IRP ; initial top of return stack
+ (fig-forth-auto680):00380 * RINIT FDB ORIG-2 initial top of return stack
+1216 6A00 (fig-forth-auto680):00381 FDB ITIB ; terminal input buffer
+ (fig-forth-auto680):00382 * FDB ORIG-$D0 terminal input buffer
+1218 001F (fig-forth-auto680):00383 FDB 31 initial name field width
+121A 0000 (fig-forth-auto680):00384 FDB 0 initial warning mode (0 = no disc)
+121C 2AD0 (fig-forth-auto680):00385 FENCIN FDB REND initial fence
+121E 2AD0 (fig-forth-auto680):00386 DPINIT FDB REND cold start value for DICTPT
+1220 2AA5 (fig-forth-auto680):00387 VOCINT FDB FORTH+4*NATWID
+1222 0084 (fig-forth-auto680):00388 COLINT FDB 132 initial terminal carriage width
+1224 0004 (fig-forth-auto680):00389 DELINT FDB 4 initial carriage return delay
+ (fig-forth-auto680):00390 ****************************************************
+ (fig-forth-auto680):00391 *
+ (fig-forth-auto680):00392 PAGE
+ (fig-forth-auto680):00393 *
+ (fig-forth-auto680):00394 * ######>> screen 13 <<
+ (fig-forth-auto680):00395 * These were of questionable use anyway,
+ (fig-forth-auto680):00396 * kept here now to satisfy the assembler and show hints.
+ (fig-forth-auto680):00397 * They're too much trouble to use with native subroutine call anyway.
+ (fig-forth-auto680):00398 * PULABX PULS A ; 24 cycles until 'NEXT'
+ (fig-forth-auto680):00399 * PULS B ;
+ (fig-forth-auto680):00400 * PULABX PULU A,B ; ?? cycles until 'NEXT'
+ (fig-forth-auto680):00401 * STABX STA 0,X 16 cycles until 'NEXT'
+ (fig-forth-auto680):00402 * STB 1,X
+ (fig-forth-auto680):00403 * STABX STD 0,X ; ?? cycles until 'NEXT'
+1226 2000 (fig-forth-auto680):00404 BRA NEXT
+ (fig-forth-auto680):00405 * GETX LDA 0,X 18 cycles until 'NEXT'
+ (fig-forth-auto680):00406 * LDB 1,X
+ (fig-forth-auto680):00407 * GETX LDD 0,X ?? cycles until 'NEXT'
+ (fig-forth-auto680):00408 * PUSHBA PSHS B ; 8 cycles until 'NEXT'
+ (fig-forth-auto680):00409 * PSHS A ;
+ (fig-forth-auto680):00410 * PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
+ (fig-forth-auto680):00411
+ (fig-forth-auto680):00412
+ (fig-forth-auto680):00413 *
+ (fig-forth-auto680):00414 * "NEXT" takes ?? cycles if TRACE is removed,
+ (fig-forth-auto680):00415 *
+ (fig-forth-auto680):00416 * and ?? cycles if trace is present and NOT tracing.
+ (fig-forth-auto680):00417 *
+ (fig-forth-auto680):00418 * = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
+ (fig-forth-auto680):00419 * =
+ (fig-forth-auto680):00420 * NEXT itself might just completely go away.
+ (fig-forth-auto680):00421 * About the only reason to keep it is to allowing executing a list
+ (fig-forth-auto680):00422 * which allows a cheap TRACE routine.
+ (fig-forth-auto680):00423 *
+ (fig-forth-auto680):00424 * NEXT is a loop which implements the Forth VM.
+ (fig-forth-auto680):00425 * It basically cycles through calling the code out of code lists,
+ (fig-forth-auto680):00426 * one at a time.
+ (fig-forth-auto680):00427 * Using a native CPU return for this uses a few extra cycles per call,
+ (fig-forth-auto680):00428 * compared to simply jumping to each definition and jumping back
+ (fig-forth-auto680):00429 * to the known beginning of the loop,
+ (fig-forth-auto680):00430 * but the loop itself is really only there for convenience.
+ (fig-forth-auto680):00431 *
+ (fig-forth-auto680):00432 * This implementation uses the native subroutine call,
+ (fig-forth-auto680):00433 * to break the wall between Forth code and non-Forth code.
+ (fig-forth-auto680):00434 *
+ (fig-forth-auto680):00435 * NEXT LDX IP
+ (fig-forth-auto680):00436 * LEAX 1,X ; pre-increment mode
+ (fig-forth-auto680):00437 * LEAX 1,X ;
+ (fig-forth-auto680):00438 * STX IP
+1228 (fig-forth-auto680):00439 NEXT ; IP is Y, push before using, pull before you come back here.
+ (fig-forth-auto680):00440 *
+ (fig-forth-auto680):00441 * NEXT2 LDX 0,X get W which points to CFA of word to be done
+1228 AEA1 (fig-forth-auto680):00442 NEXT2 LDX ,Y++ get W which points to CFA of word to be done
+122A 8D08 (fig-forth-auto680):00443 BSR DBGNAM
+122C 8D58 (fig-forth-auto680):00444 BSR DBGREG
+ (fig-forth-auto680):00445 * But NEXT2 is too much trouble to use with subroutine threading anyway.
+ (fig-forth-auto680):00446 * NEXT3 STX W
+122E (fig-forth-auto680):00447 NEXT3 ; W is X until you use X for something else. (TOS points back here.)
+ (fig-forth-auto680):00448 * But NEXT3 is too much trouble to use with subroutine threading anyway.
+ (fig-forth-auto680):00449 * LDX 0,X get VECT which points to executable code
+ (fig-forth-auto680):00450 * =
+ (fig-forth-auto680):00451 * The next instruction could be patched to JMP TRACE =
+ (fig-forth-auto680):00452 * if a TRACE routine is available: =
+ (fig-forth-auto680):00453 * =
+ (fig-forth-auto680):00454 * JMP 0,X
+ (fig-forth-auto680):00455
+122E AD94 (fig-forth-auto680):00456 JSR [,X] ; Saving the postinc cycles,
+ (fig-forth-auto680):00457 * ; but X must be bumped NATWID to the parameters.
+ (fig-forth-auto680):00458 * NOP
+ (fig-forth-auto680):00459 * JMP TRACE ( an alternate for the above )
+1230 8D54 (fig-forth-auto680):00460 BSR DBGREG ( an alternate for the above )
+ (fig-forth-auto680):00461 * In other words, with the call and the NOP,
+ (fig-forth-auto680):00462 * there is room to patch the call with a JMP to your TRACE
+ (fig-forth-auto680):00463 * routine, which you have to provide.
+1232 20F4 (fig-forth-auto680):00464 BRA NEXT
+ (fig-forth-auto680):00465 *
+1234 3437 (fig-forth-auto680):00466 DBGNAM PSHS CC,D,X,Y
+1236 0D0B (fig-forth-auto680):00467 TST <TRACEM
+1238 2724 (fig-forth-auto680):00468 BEQ DBGNrt
+123A 301D (fig-forth-auto680):00469 LEAX -3,X
+123C E682 (fig-forth-auto680):00470 DBGNlf LDB ,-X
+123E 2AFC (fig-forth-auto680):00471 BPL DBGNlf
+1240 108E04C0 (fig-forth-auto680):00472 LDY #$4C0
+1244 E680 (fig-forth-auto680):00473 LDB ,X+
+1246 E680 (fig-forth-auto680):00474 DBGNlp LDB ,X+
+1248 2B04 (fig-forth-auto680):00475 BMI DBGNll
+124A E7A0 (fig-forth-auto680):00476 STB ,Y+
+124C 20F8 (fig-forth-auto680):00477 BRA DBGNlp
+124E C47F (fig-forth-auto680):00478 DBGNll ANDB #$7F
+1250 E7A0 (fig-forth-auto680):00479 STB ,Y+
+1252 C660 (fig-forth-auto680):00480 LDB #$60
+1254 2002 (fig-forth-auto680):00481 BRA DBGNlt
+1256 E7A0 (fig-forth-auto680):00482 DBGNlc STB ,Y+
+1258 108C04E0 (fig-forth-auto680):00483 DBGNlt CMPY #$4E0
+125C 25F8 (fig-forth-auto680):00484 BLO DBGNlc
+125E 35B7 (fig-forth-auto680):00485 DBGNrt PULS CC,D,X,Y,PC
+ (fig-forth-auto680):00486 *
+ (fig-forth-auto680):00487 *
+1260 54 (fig-forth-auto680):00488 MKhxBh LSRB
+1261 54 (fig-forth-auto680):00489 LSRB
+1262 54 (fig-forth-auto680):00490 LSRB
+1263 54 (fig-forth-auto680):00491 LSRB
+1264 C40F (fig-forth-auto680):00492 MKhxBl ANDB #$0F
+1266 CB30 (fig-forth-auto680):00493 ADDB #$30
+1268 C139 (fig-forth-auto680):00494 CMPB #$39
+126A 2302 (fig-forth-auto680):00495 BLS MKhxBx
+126C CBC7 (fig-forth-auto680):00496 ADDB #$C7 ; ($40-$39)-$40
+126E 39 (fig-forth-auto680):00497 MKhxBx RTS
+ (fig-forth-auto680):00498 *
+126F 1E89 (fig-forth-auto680):00499 OUThxA EXG A,B
+1271 8D05 (fig-forth-auto680):00500 BSR OUThxB
+1273 1E89 (fig-forth-auto680):00501 EXG A,B
+1275 39 (fig-forth-auto680):00502 RTS
+ (fig-forth-auto680):00503 *
+1276 8DF7 (fig-forth-auto680):00504 OUThxD BSR OUThxA
+1278 3404 (fig-forth-auto680):00505 OUThxB PSHS B
+127A 8DE4 (fig-forth-auto680):00506 BSR MKhxBh
+127C E780 (fig-forth-auto680):00507 STB ,X+
+127E E6E4 (fig-forth-auto680):00508 LDB ,S
+1280 8DE2 (fig-forth-auto680):00509 BSR MKhxBl
+1282 E780 (fig-forth-auto680):00510 STB ,X+
+1284 3584 (fig-forth-auto680):00511 PULS B,PC
+ (fig-forth-auto680):00512 *
+1286 347F (fig-forth-auto680):00513 DBGREG PSHS U,Y,X,DP,B,A,CC
+1288 0D0B (fig-forth-auto680):00514 TST <TRACEM
+128A 102700DF (fig-forth-auto680):00515 LBEQ DBGRrt
+128E 318D00DD (fig-forth-auto680):00516 LEAY DBGRLB,PCR
+1292 8E04E0 (fig-forth-auto680):00517 LDX #$4E0
+1295 ECA1 (fig-forth-auto680):00518 DBGRlp LDD ,Y++
+1297 2704 (fig-forth-auto680):00519 BEQ DBGRdn
+1299 ED81 (fig-forth-auto680):00520 STD ,X++
+129B 20F8 (fig-forth-auto680):00521 BRA DBGRlp
+129D 8E0500 (fig-forth-auto680):00522 DBGRdn LDX #$500
+12A0 A663 (fig-forth-auto680):00523 LDA 3,S ; DP
+12A2 E6E4 (fig-forth-auto680):00524 LDB ,S ; CC
+12A4 8DD0 (fig-forth-auto680):00525 BSR OUThxD
+12A6 C660 (fig-forth-auto680):00526 LDB #$60
+12A8 E780 (fig-forth-auto680):00527 STB ,X+
+12AA EC6A (fig-forth-auto680):00528 LDD 3*NATWID+4,S ; PC:505
+12AC 8DC8 (fig-forth-auto680):00529 BSR OUThxD
+12AE C660 (fig-forth-auto680):00530 LDB #$60
+12B0 E780 (fig-forth-auto680):00531 STB ,X+
+12B2 1F40 (fig-forth-auto680):00532 TFR S,D ; 509
+12B4 C3000C (fig-forth-auto680):00533 ADDD #4*NATWID+4
+12B7 8DBD (fig-forth-auto680):00534 BSR OUThxD
+12B9 EC68 (fig-forth-auto680):00535 LDD 2*NATWID+4,S ; U:50E
+12BB 8DB9 (fig-forth-auto680):00536 BSR OUThxD
+12BD C660 (fig-forth-auto680):00537 LDB #$60
+12BF E780 (fig-forth-auto680):00538 STB ,X+
+12C1 EC66 (fig-forth-auto680):00539 LDD 1*NATWID+4,S ; Y:513
+12C3 8DB1 (fig-forth-auto680):00540 BSR OUThxD
+12C5 EC64 (fig-forth-auto680):00541 LDD 0*NATWID+4,S ; X at 517
+12C7 8DAD (fig-forth-auto680):00542 BSR OUThxD
+12C9 C660 (fig-forth-auto680):00543 LDB #$60
+12CB E780 (fig-forth-auto680):00544 STB ,X+
+12CD EC61 (fig-forth-auto680):00545 LDD 1,S ; D at 51C
+12CF 8DA5 (fig-forth-auto680):00546 BSR OUThxD
+12D1 C660 (fig-forth-auto680):00547 LDB #$60
+12D3 E780 (fig-forth-auto680):00548 STB ,X+
+12D5 E780 (fig-forth-auto680):00549 STB ,X+
+12D7 E780 (fig-forth-auto680):00550 STB ,X+
+12D9 E780 (fig-forth-auto680):00551 STB ,X+
+12DB E780 (fig-forth-auto680):00552 STB ,X+
+12DD ECF80A (fig-forth-auto680):00553 LDD [3*NATWID+4,S] ; PC
+12E0 8D94 (fig-forth-auto680):00554 BSR OUThxD
+12E2 C660 (fig-forth-auto680):00555 LDB #$60
+12E4 E780 (fig-forth-auto680):00556 STB ,X+
+12E6 EC6C (fig-forth-auto680):00557 LDD 4*NATWID+4,S ; S
+12E8 8D8C (fig-forth-auto680):00558 BSR OUThxD
+12EA ECF808 (fig-forth-auto680):00559 LDD [2*NATWID+4,S] ; U
+12ED 8D87 (fig-forth-auto680):00560 BSR OUThxD
+12EF C660 (fig-forth-auto680):00561 LDB #$60
+12F1 E780 (fig-forth-auto680):00562 STB ,X+
+12F3 ECF806 (fig-forth-auto680):00563 LDD [1*NATWID+4,S] ; Y
+12F6 17FF7D (fig-forth-auto680):00564 LBSR OUThxD
+12F9 ECF804 (fig-forth-auto680):00565 LDD [0*NATWID+4,S] ; X
+12FC 17FF77 (fig-forth-auto680):00566 LBSR OUThxD
+12FF C660 (fig-forth-auto680):00567 LDB #$60
+1301 E780 (fig-forth-auto680):00568 STB ,X+
+1303 E780 (fig-forth-auto680):00569 STB ,X+
+1305 E780 (fig-forth-auto680):00570 STB ,X+
+1307 E780 (fig-forth-auto680):00571 STB ,X+
+1309 E780 (fig-forth-auto680):00572 STB ,X+
+130B C600 (fig-forth-auto680):00573 LDB #0
+130D 1E9B (fig-forth-auto680):00574 EXG B,DP
+130F AD9FA000 (fig-forth-auto680):00575 DBGRkl JSR [$A000]
+1313 27FA (fig-forth-auto680):00576 BEQ DBGRkl
+1315 FD043E (fig-forth-auto680):00577 STD $43E
+1318 1EB9 (fig-forth-auto680):00578 EXG DP,B
+131A 8155 (fig-forth-auto680):00579 CMPA #$55 ; 'U'
+131C 273C (fig-forth-auto680):00580 BEQ DBGRdU
+131E 8153 (fig-forth-auto680):00581 CMPA #$53 ; 'S'
+1320 271E (fig-forth-auto680):00582 BEQ DBGRdS
+1322 8149 (fig-forth-auto680):00583 CMPA #$49 ; 'I'
+1324 2647 (fig-forth-auto680):00584 BNE DBGRrt
+1326 DC22 (fig-forth-auto680):00585 DBGRin LDD <XTIB
+1328 D330 (fig-forth-auto680):00586 ADDD <XIN
+132A 1F02 (fig-forth-auto680):00587 TFR D,Y
+132C 17FF47 (fig-forth-auto680):00588 LBSR OUThxD
+132F C63A (fig-forth-auto680):00589 LDB #$3a ; ':'
+1331 E780 (fig-forth-auto680):00590 STB ,X+
+1333 964C (fig-forth-auto680):00591 LDA <XCOLUM
+1335 E6A0 (fig-forth-auto680):00592 DBGRip LDB ,Y+
+1337 E780 (fig-forth-auto680):00593 STB ,X+
+1339 2732 (fig-forth-auto680):00594 BEQ DBGRrt
+133B 4A (fig-forth-auto680):00595 DBGRit DECA
+133C 26F7 (fig-forth-auto680):00596 BNE DBGRip
+133E 202D (fig-forth-auto680):00597 BRA DBGRrt
+1340 1F42 (fig-forth-auto680):00598 DBGRdS TFR S,Y
+1342 2009 (fig-forth-auto680):00599 BRA DBGRst
+1344 ECA1 (fig-forth-auto680):00600 DBGRsp LDD ,Y++
+1346 17FF2D (fig-forth-auto680):00601 LBSR OUThxD
+1349 C660 (fig-forth-auto680):00602 LDB #$60
+134B E780 (fig-forth-auto680):00603 STB ,X+
+134D 109C20 (fig-forth-auto680):00604 DBGRst CMPY <XRZERO
+1350 25F2 (fig-forth-auto680):00605 BLO DBGRsp
+1352 C63A (fig-forth-auto680):00606 LDB #$3a ; ':'
+1354 E780 (fig-forth-auto680):00607 STB ,X+
+1356 C655 (fig-forth-auto680):00608 LDB #$55
+1358 E780 (fig-forth-auto680):00609 STB ,X+
+135A 10AE68 (fig-forth-auto680):00610 DBGRdU LDY 2*NATWID+4,S
+135D 2009 (fig-forth-auto680):00611 BRA DBGRut
+135F ECA1 (fig-forth-auto680):00612 DBGRup LDD ,Y++
+1361 17FF12 (fig-forth-auto680):00613 LBSR OUThxD
+1364 C660 (fig-forth-auto680):00614 LDB #$60
+1366 E780 (fig-forth-auto680):00615 STB ,X+
+1368 109C1E (fig-forth-auto680):00616 DBGRut CMPY <XSPZER
+136B 25F2 (fig-forth-auto680):00617 BLO DBGRup
+136D 35FF (fig-forth-auto680):00618 DBGRrt PULS CC,A,B,DP,X,Y,U,PC
+136F 4450434320504320 (fig-forth-auto680):00619 DBGRLB FCC 'DPCC PC S U Y X A B '
+ 2020532020205520
+ 2020205920202058
+ 2020202041204220
+138F 00000000 (fig-forth-auto680):00620 FDB 0,0
+ (fig-forth-auto680):00621
+ (fig-forth-auto680):00622
+ (fig-forth-auto680):00623 *
+ (fig-forth-auto680):00624 * =
+ (fig-forth-auto680):00625 * = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
+ (fig-forth-auto680):00626
+ (fig-forth-auto680):00627
+ (fig-forth-auto680):00628 PAGE
+ (fig-forth-auto680):00629 *
+ (fig-forth-auto680):00630 * ======>> 1 <<
+ (fig-forth-auto680):00631 * ( --- n )
+ (fig-forth-auto680):00632 * Pushes the following natural width integer from the instruction stream
+ (fig-forth-auto680):00633 * as a literal, or immediate value.
+ (fig-forth-auto680):00634 *
+ (fig-forth-auto680):00635 * FDB {OP}
+ (fig-forth-auto680):00636 * FDB {OP}
+ (fig-forth-auto680):00637 * FDB LIT
+ (fig-forth-auto680):00638 * FDB LITERAL-TO-BE-PUSHED
+ (fig-forth-auto680):00639 * FDB {OP}
+ (fig-forth-auto680):00640 *
+ (fig-forth-auto680):00641 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00642 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00643 * (Note that there is no compile-only flag in the fig model.)
+ (fig-forth-auto680):00644 *
+ (fig-forth-auto680):00645 * See (FIND), or PFIND , for layout of the header format.
+ (fig-forth-auto680):00646 *
+1393 83 (fig-forth-auto680):00647 FCB $83
+1394 4C49 (fig-forth-auto680):00648 FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
+1396 D4 (fig-forth-auto680):00649 FCB $D4 ; 'T'|'\x80' ; character code for T, with high bit set.
+1397 0000 (fig-forth-auto680):00650 FDB 0 ; link of zero to terminate dictionary scan
+1399 139B (fig-forth-auto680):00651 LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
+139B ECA1 (fig-forth-auto680):00652 LDD ,Y++
+139D 3606 (fig-forth-auto680):00653 PSHU A,B
+139F 39 (fig-forth-auto680):00654 RTS
+ (fig-forth-auto680):00655 * LDX IP
+ (fig-forth-auto680):00656 * LEAX 1,X ;
+ (fig-forth-auto680):00657 * LEAX 1,X ;
+ (fig-forth-auto680):00658 * STX IP
+ (fig-forth-auto680):00659 * LDA 0,X
+ (fig-forth-auto680):00660 * LDB 1,X
+ (fig-forth-auto680):00661 * JMP PUSHBA
+ (fig-forth-auto680):00662 *
+ (fig-forth-auto680):00663 * ######>> screen 14 <<
+ (fig-forth-auto680):00664 * ======>> 2 <<
+ (fig-forth-auto680):00665 * ( --- n )
+ (fig-forth-auto680):00666 * Pushes the following byte from the instruction stream
+ (fig-forth-auto680):00667 * as a literal, or immediate value.
+ (fig-forth-auto680):00668 *
+ (fig-forth-auto680):00669 * FDB {OP}
+ (fig-forth-auto680):00670 * FDB {OP}
+ (fig-forth-auto680):00671 * FDB LIT8
+ (fig-forth-auto680):00672 * FCB LITERAL-TO-BE-PUSHED
+ (fig-forth-auto680):00673 * FDB {OP}
+ (fig-forth-auto680):00674 *
+ (fig-forth-auto680):00675 * If this is kept, it should have a header for TRACE to read.
+ (fig-forth-auto680):00676 * If the data bus is wider than a byte, you don't want to do this.
+ (fig-forth-auto680):00677 * Byte shaving like this is often counter-productive anyway.
+ (fig-forth-auto680):00678 * Changing the name to LIT8, hoping that will be more understandable.
+ (fig-forth-auto680):00679 * Also, see comments for LIT.
+ (fig-forth-auto680):00680 * (Note that there is no compile-only flag in the fig model.)
+13A0 84 (fig-forth-auto680):00681 FCB $84
+13A1 4C4954 (fig-forth-auto680):00682 FCC 'LIT' ; 'LIT8' : NOTE: this is different from LITERAL
+13A4 B8 (fig-forth-auto680):00683 FCB $B8
+13A5 1393 (fig-forth-auto680):00684 FDB LIT-6
+13A7 13A9 (fig-forth-auto680):00685 LIT8 FDB *+NATWID (this was an invisible word, with no header)
+13A9 E6A0 (fig-forth-auto680):00686 LDB ,Y+ ; This also is meaningless in native code.
+13AB 4F (fig-forth-auto680):00687 CLRA
+13AC 3606 (fig-forth-auto680):00688 PSHU A,B
+13AE 39 (fig-forth-auto680):00689 RTS
+ (fig-forth-auto680):00690 * LDX IP
+ (fig-forth-auto680):00691 * LEAX 1,X ;
+ (fig-forth-auto680):00692 * STX IP
+ (fig-forth-auto680):00693 * CLRA ;
+ (fig-forth-auto680):00694 * LDB 1,X
+ (fig-forth-auto680):00695 * JMP PUSHBA
+ (fig-forth-auto680):00696 *
+ (fig-forth-auto680):00697 * ( n off --- n )
+ (fig-forth-auto680):00698 * off is offset in video buffer area.
+13AF 87 (fig-forth-auto680):00699 FCB $87
+13B0 53484F57544F (fig-forth-auto680):00700 FCC 'SHOWTO' ; 'SHOWTOS'
+13B6 D3 (fig-forth-auto680):00701 FCB $D3 ; 'S'
+13B7 13A0 (fig-forth-auto680):00702 FDB LIT8-7
+13B9 13BB (fig-forth-auto680):00703 SHOTOS FDB *+NATWID
+13BB 8E0400 (fig-forth-auto680):00704 LDX #$400
+13BE ECC1 (fig-forth-auto680):00705 LDD ,U++
+13C0 308B (fig-forth-auto680):00706 LEAX D,X
+13C2 ECC4 (fig-forth-auto680):00707 LDD ,U
+13C4 17FEAF (fig-forth-auto680):00708 LBSR OUThxD
+13C7 39 (fig-forth-auto680):00709 RTS
+ (fig-forth-auto680):00710 *
+13C8 85 (fig-forth-auto680):00711 FCB $85
+13C9 54524F46 (fig-forth-auto680):00712 FCC 'TROF' ; 'TROFF'
+13CD C6 (fig-forth-auto680):00713 FCB $C6 ; 'F'|$80
+13CE 13AF (fig-forth-auto680):00714 FDB SHOTOS-10
+13D0 13D2 (fig-forth-auto680):00715 TROFF FDB *+NATWID
+13D2 0F0B (fig-forth-auto680):00716 CLR <TRACEM
+13D4 39 (fig-forth-auto680):00717 RTS
+ (fig-forth-auto680):00718 *
+13D5 84 (fig-forth-auto680):00719 FCB $84
+13D6 54524F (fig-forth-auto680):00720 FCC 'TRO' ; 'TRON'
+13D9 CE (fig-forth-auto680):00721 FCB $CE ; 'N'|$80
+13DA 13C8 (fig-forth-auto680):00722 FDB TROFF-8
+13DC 13DE (fig-forth-auto680):00723 TRON FDB *+NATWID
+13DE 0C0B (fig-forth-auto680):00724 INC <TRACEM
+13E0 39 (fig-forth-auto680):00725 RTS
+ (fig-forth-auto680):00726 *
+ (fig-forth-auto680):00727 * ======>> 3 <<
+ (fig-forth-auto680):00728 * ( adr --- )
+ (fig-forth-auto680):00729 * Jump to address on stack. Used by the "outer" interpreter to
+ (fig-forth-auto680):00730 * interactively invoke routines.
+ (fig-forth-auto680):00731 * Might be useful to have EXECUTE test the pointer, as done in BIF-6809.
+13E1 87 (fig-forth-auto680):00732 FCB $87
+13E2 455845435554 (fig-forth-auto680):00733 FCC 'EXECUT' ; 'EXECUTE'
+13E8 C5 (fig-forth-auto680):00734 FCB $C5
+13E9 13D5 (fig-forth-auto680):00735 FDB TRON-7
+13EB 13ED (fig-forth-auto680):00736 EXEC FDB *+NATWID
+13ED 3710 (fig-forth-auto680):00737 PULU X ; Gotta have W anyway, just in case.
+13EF 6E94 (fig-forth-auto680):00738 JMP [,X] ; Tail return.
+ (fig-forth-auto680):00739 * TFR S,X ; TSX :
+ (fig-forth-auto680):00740 * LDX 0,X get code field address (CFA)
+ (fig-forth-auto680):00741 * LEAS 1,S ; pop stack
+ (fig-forth-auto680):00742 * LEAS 1,S ;
+ (fig-forth-auto680):00743 * JMP NEXT3
+ (fig-forth-auto680):00744 *
+ (fig-forth-auto680):00745 * ######>> screen 15 <<
+ (fig-forth-auto680):00746 * ======>> 4 <<
+ (fig-forth-auto680):00747 * ( --- ) C
+ (fig-forth-auto680):00748 * Add the following word from the instruction stream to the
+ (fig-forth-auto680):00749 * instruction pointer (Y++). Causes a program branch in Forth code stream.
+ (fig-forth-auto680):00750 *
+ (fig-forth-auto680):00751 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00752 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00753 * This is only for Forth code stream.
+ (fig-forth-auto680):00754 * Also, see comments for LIT.
+13F1 86 (fig-forth-auto680):00755 FCB $86
+13F2 4252414E43 (fig-forth-auto680):00756 FCC 'BRANC' ; 'BRANCH'
+13F7 C8 (fig-forth-auto680):00757 FCB $C8
+13F8 13E1 (fig-forth-auto680):00758 FDB EXEC-10
+13FA 140F (fig-forth-auto680):00759 BRAN FDB ZBYES ; Go steal code in ZBRANCH
+ (fig-forth-auto680):00760
+ (fig-forth-auto680):00761 * Moving code around to optimize the branch taking case in 0BRANCH.
+13FC 3122 (fig-forth-auto680):00762 ZBNO LEAY NATWID,Y ; No branch.
+13FE 39 (fig-forth-auto680):00763 RTS
+ (fig-forth-auto680):00764 * ======>> 5 <<
+ (fig-forth-auto680):00765 * ( f --- ) C
+ (fig-forth-auto680):00766 * BRANCH if flag is zero.
+ (fig-forth-auto680):00767 *
+ (fig-forth-auto680):00768 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00769 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00770 * This is only for Forth code stream.
+ (fig-forth-auto680):00771 * Also, see comments for LIT.
+13FF 87 (fig-forth-auto680):00772 FCB $87
+1400 304252414E43 (fig-forth-auto680):00773 FCC '0BRANC' ; '0BRANCH'
+1406 C8 (fig-forth-auto680):00774 FCB $C8
+1407 13F1 (fig-forth-auto680):00775 FDB BRAN-9
+1409 140B (fig-forth-auto680):00776 ZBRAN FDB *+NATWID
+140B ECC1 (fig-forth-auto680):00777 LDD ,U++
+140D 26ED (fig-forth-auto680):00778 BNE ZBNO
+140F ECA1 (fig-forth-auto680):00779 ZBYES LDD ,Y++
+1411 31AB (fig-forth-auto680):00780 LEAY D,Y ; IP is postinc
+1413 39 (fig-forth-auto680):00781 RTS
+ (fig-forth-auto680):00782 * PULS A ;
+ (fig-forth-auto680):00783 * PULS B ;
+ (fig-forth-auto680):00784 * PSHS B ; ** emulating ABA:
+ (fig-forth-auto680):00785 * ADDA ,S+ ;
+ (fig-forth-auto680):00786 * BNE ZBNO
+ (fig-forth-auto680):00787 * BCS ZBNO
+ (fig-forth-auto680):00788 * ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
+ (fig-forth-auto680):00789 * LDB 3,X
+ (fig-forth-auto680):00790 * LDA 2,X
+ (fig-forth-auto680):00791 * ADDB IP+1
+ (fig-forth-auto680):00792 * ADCA IP
+ (fig-forth-auto680):00793 * STB IP+1
+ (fig-forth-auto680):00794 * STA IP
+ (fig-forth-auto680):00795 * JMP NEXT
+ (fig-forth-auto680):00796 * ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
+ (fig-forth-auto680):00797 * LEAX 1,X ; jump over branch delta
+ (fig-forth-auto680):00798 * LEAX 1,X ;
+ (fig-forth-auto680):00799 * STX IP
+ (fig-forth-auto680):00800 * JMP NEXT
+ (fig-forth-auto680):00801 *
+ (fig-forth-auto680):00802 * ######>> screen 16 <<
+ (fig-forth-auto680):00803 * ======>> 6 <<
+ (fig-forth-auto680):00804 * ( --- ) ( limit index *** limit index+1) C
+ (fig-forth-auto680):00805 * ( limit index *** )
+ (fig-forth-auto680):00806 * Counting loop primitive. The counter and limit are the top two
+ (fig-forth-auto680):00807 * words on the return stack. If the updated index/counter does
+ (fig-forth-auto680):00808 * not exceed the limit, a branch occurs. If it does, the branch
+ (fig-forth-auto680):00809 * does not occur, and the index and limit are dropped from the
+ (fig-forth-auto680):00810 * return stack.
+ (fig-forth-auto680):00811 *
+ (fig-forth-auto680):00812 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00813 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00814 * This is only for Forth code stream.
+ (fig-forth-auto680):00815 * Also, see comments for LIT.
+1414 86 (fig-forth-auto680):00816 FCB $86
+1415 284C4F4F50 (fig-forth-auto680):00817 FCC '(LOOP' ; '(LOOP)'
+141A A9 (fig-forth-auto680):00818 FCB $A9
+141B 13FF (fig-forth-auto680):00819 FDB ZBRAN-10
+141D 141F (fig-forth-auto680):00820 XLOOP FDB *+NATWID
+141F CC0001 (fig-forth-auto680):00821 LDD #1 ; Borrowing from BIF-6809.
+1422 E362 (fig-forth-auto680):00822 XLOOPA ADDD NATWID,S ; Dodge the return address.
+1424 ED62 (fig-forth-auto680):00823 STD NATWID,S
+1426 A364 (fig-forth-auto680):00824 SUBD 2*NATWID,S
+1428 2DE5 (fig-forth-auto680):00825 BLT ZBYES ; signed
+142A 3122 (fig-forth-auto680):00826 XLOOPN LEAY NATWID,Y
+142C AEE4 (fig-forth-auto680):00827 LDX ,S ; synthetic return
+142E 3266 (fig-forth-auto680):00828 LEAS 3*NATWID,S ; Clean up the index and limit.
+1430 6E84 (fig-forth-auto680):00829 JMP ,X
+ (fig-forth-auto680):00830 * CLRA ;
+ (fig-forth-auto680):00831 * LDB #1 get set to increment counter by 1 (Clears N.)
+ (fig-forth-auto680):00832 * BRA XPLOP2 go steal other guy's code!
+ (fig-forth-auto680):00833 *
+ (fig-forth-auto680):00834 * ======>> 7 <<
+ (fig-forth-auto680):00835 * ( n --- ) ( limit index *** limit index+n ) C
+ (fig-forth-auto680):00836 * ( limit index *** )
+ (fig-forth-auto680):00837 * Loop with a variable increment. Terminates when the index
+ (fig-forth-auto680):00838 * crosses the boundary from one below the limit to the limit. A
+ (fig-forth-auto680):00839 * positive n will cause termination if the result index equals the
+ (fig-forth-auto680):00840 * limit. A negative n must cause the index to become less than
+ (fig-forth-auto680):00841 * the limit to cause loop termination.
+ (fig-forth-auto680):00842 *
+ (fig-forth-auto680):00843 * Note that the end conditions are not symmetric around zero.
+ (fig-forth-auto680):00844 *
+ (fig-forth-auto680):00845 * In native processor code, there should be a better way, use that instead.
+ (fig-forth-auto680):00846 * More specifically, DO NOT CALL THIS from assembly language code.
+ (fig-forth-auto680):00847 * This is only for Forth code stream.
+ (fig-forth-auto680):00848 * Also, see comments for LIT.
+1432 87 (fig-forth-auto680):00849 FCB $87
+1433 282B4C4F4F50 (fig-forth-auto680):00850 FCC '(+LOOP' ; '(+LOOP)'
+1439 A9 (fig-forth-auto680):00851 FCB $A9
+143A 1414 (fig-forth-auto680):00852 FDB XLOOP-9
+143C 143E (fig-forth-auto680):00853 XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
+143E ECC1 (fig-forth-auto680):00854 LDD ,U++ ; inc val
+1440 2AE0 (fig-forth-auto680):00855 BPL XLOOPA ; Steal plain loop code for forward count.
+1442 E362 (fig-forth-auto680):00856 ADDD NATWID,S ; Dodge the return address
+1444 ED62 (fig-forth-auto680):00857 STD NATWID,S
+1446 A364 (fig-forth-auto680):00858 SUBD 2*NATWID,S
+1448 2EC5 (fig-forth-auto680):00859 BGT ZBYES ; signed
+144A 20DE (fig-forth-auto680):00860 BRA XLOOPN ; This path is less time-sensitive.
+ (fig-forth-auto680):00861 *
+ (fig-forth-auto680):00862 * This should work, but I want to use tested code.
+ (fig-forth-auto680):00863 * PULU A,B ; Get the increment.
+ (fig-forth-auto680):00864 * XPLOP2 PULS X ; Pre-clear the return stack.
+ (fig-forth-auto680):00865 * PSHU A ; Save the direction in high bit.
+ (fig-forth-auto680):00866 * ADDD ,S ; Count.
+ (fig-forth-auto680):00867 * STD ,S ; Update.
+ (fig-forth-auto680):00868 * SUBD NATWID,S ; Check limit.
+ (fig-forth-auto680):00869 **
+ (fig-forth-auto680):00870 ** I think this should work:
+ (fig-forth-auto680):00871 * EORA ,U+ ; dir < 0 and (count - limit) >= 0
+ (fig-forth-auto680):00872 * BPL XPLONO ; or dir >= 0 and (count - limit) < 0
+ (fig-forth-auto680):00873 * LDD ,Y++
+ (fig-forth-auto680):00874 * LEAY D,Y ; IP is postinc
+ (fig-forth-auto680):00875 * JMP ,X
+ (fig-forth-auto680):00876 * XPLONO LEAS 2*NATWID,S
+ (fig-forth-auto680):00877 * JMP ,X ; synthetic return
+ (fig-forth-auto680):00878 *
+ (fig-forth-auto680):00879 * This definitely should work:
+ (fig-forth-auto680):00880 * TST ,U+ ; Get the sign
+ (fig-forth-auto680):00881 * BPL XPLOF ;
+ (fig-forth-auto680):00882 * CMPD NATWID,S
+ (fig-forth-auto680):00883 * BMI XPLONO
+ (fig-forth-auto680):00884 * XPLOYE LDD ,Y++
+ (fig-forth-auto680):00885 * LEAY D,Y ; IP is postinc
+ (fig-forth-auto680):00886 * JMP ,X
+ (fig-forth-auto680):00887 * XPLOF CMPD NATWID,S
+ (fig-forth-auto680):00888 * BMI XPLOYE
+ (fig-forth-auto680):00889 * XPLONO LEAS 2*NATWID,S
+ (fig-forth-auto680):00890 * JMP ,X ; synthetic return
+ (fig-forth-auto680):00891 *
+ (fig-forth-auto680):00892 * 6800 Probably could have used the exclusive-or method, too.:
+ (fig-forth-auto680):00893 * PULS A ; get increment
+ (fig-forth-auto680):00894 * PULS B ;
+ (fig-forth-auto680):00895 * XPLOP2 TSTA ;
+ (fig-forth-auto680):00896 * BPL XPLOF forward looping
+ (fig-forth-auto680):00897 * BSR XPLOPS
+ (fig-forth-auto680):00898 * ORCC #$01 ; SEC :
+ (fig-forth-auto680):00899 * SBCB 5,X
+ (fig-forth-auto680):00900 * SBCA 4,X
+ (fig-forth-auto680):00901 * BPL ZBYES
+ (fig-forth-auto680):00902 * BRA XPLONO fall through
+ (fig-forth-auto680):00903 *
+ (fig-forth-auto680):00904 * the subroutine :
+ (fig-forth-auto680):00905 * XPLOPS LDX RP
+ (fig-forth-auto680):00906 * ADDB 3,X add it to counter
+ (fig-forth-auto680):00907 * ADCA 2,X
+ (fig-forth-auto680):00908 * STB 3,X store new counter value
+ (fig-forth-auto680):00909 * STA 2,X
+ (fig-forth-auto680):00910 * RTS
+ (fig-forth-auto680):00911 *
+ (fig-forth-auto680):00912 * XPLOF BSR XPLOPS
+ (fig-forth-auto680):00913 * SUBB 5,X
+ (fig-forth-auto680):00914 * SBCA 4,X
+ (fig-forth-auto680):00915 * BMI ZBYES
+ (fig-forth-auto680):00916 *
+ (fig-forth-auto680):00917 * XPLONO LEAX 1,X ; done, don't branch back
+ (fig-forth-auto680):00918 * LEAX 1,X ;
+ (fig-forth-auto680):00919 * LEAX 1,X ;
+ (fig-forth-auto680):00920 * LEAX 1,X ;
+ (fig-forth-auto680):00921 * STX RP
+ (fig-forth-auto680):00922 * BRA ZBNO use ZBRAN to skip over unused delta
+ (fig-forth-auto680):00923 *
+ (fig-forth-auto680):00924 * ######>> screen 17 <<
+ (fig-forth-auto680):00925 * ======>> 8 <<
+ (fig-forth-auto680):00926 * ( limit index --- ) ( *** limit index )
+ (fig-forth-auto680):00927 * Move the loop parameters to the return stack. Synonym for D>R.
+144C 84 (fig-forth-auto680):00928 FCB $84
+144D 28444F (fig-forth-auto680):00929 FCC '(DO' ; '(DO)'
+1450 A9 (fig-forth-auto680):00930 FCB $A9
+1451 1432 (fig-forth-auto680):00931 FDB XPLOOP-10
+1453 1455 (fig-forth-auto680):00932 XDO FDB *+NATWID This is the RUNTIME DO, not the COMPILING DO
+1455 AEE4 (fig-forth-auto680):00933 LDX ,S ; Save the return address.
+1457 3706 (fig-forth-auto680):00934 PULU A,B
+1459 3406 (fig-forth-auto680):00935 PSHS A,B
+145B 3706 (fig-forth-auto680):00936 PULU A,B ; Maintain order.
+145D ED62 (fig-forth-auto680):00937 STD NATWID,S
+145F 6E84 (fig-forth-auto680):00938 JMP ,X ; synthetic return
+ (fig-forth-auto680):00939 *
+ (fig-forth-auto680):00940 * LDX RP
+ (fig-forth-auto680):00941 * LEAX -1,X ;
+ (fig-forth-auto680):00942 * LEAX -1,X ;
+ (fig-forth-auto680):00943 * LEAX -1,X ;
+ (fig-forth-auto680):00944 * LEAX -1,X ;
+ (fig-forth-auto680):00945 * STX RP
+ (fig-forth-auto680):00946 * PULS A ;
+ (fig-forth-auto680):00947 * PULS B ;
+ (fig-forth-auto680):00948 * STA 2,X
+ (fig-forth-auto680):00949 * STB 3,X
+ (fig-forth-auto680):00950 * PULS A ;
+ (fig-forth-auto680):00951 * PULS B ;
+ (fig-forth-auto680):00952 * STA 4,X
+ (fig-forth-auto680):00953 * STB 5,X
+ (fig-forth-auto680):00954 * JMP NEXT
+ (fig-forth-auto680):00955 *
+ (fig-forth-auto680):00956 * ======>> 9 <<
+ (fig-forth-auto680):00957 * ( --- index ) ( limit index *** limit index )
+ (fig-forth-auto680):00958 * Copy the loop index from the return stack. Synonym for R.
+1461 81 (fig-forth-auto680):00959 FCB $81 I
+1462 C9 (fig-forth-auto680):00960 FCB $C9
+1463 144C (fig-forth-auto680):00961 FDB XDO-7
+1465 1467 (fig-forth-auto680):00962 I FDB *+NATWID
+1467 EC62 (fig-forth-auto680):00963 LDD NATWID,S ; Dodge return address.
+1469 3606 (fig-forth-auto680):00964 PSHU A,B
+146B 39 (fig-forth-auto680):00965 RTS
+ (fig-forth-auto680):00966 * LDX RP
+ (fig-forth-auto680):00967 * LEAX 1,X ;
+ (fig-forth-auto680):00968 * LEAX 1,X ;
+ (fig-forth-auto680):00969 * JMP GETX
+ (fig-forth-auto680):00970 *
+ (fig-forth-auto680):00971 * ######>> screen 18 <<
+ (fig-forth-auto680):00972 * ======>> 10 <<
+ (fig-forth-auto680):00973 * ( c base --- false )
+ (fig-forth-auto680):00974 * ( c base --- n true )
+ (fig-forth-auto680):00975 * Translate C in base, yielding a translation valid flag. If the
+ (fig-forth-auto680):00976 * translation is not valid in the specified base, only the false
+ (fig-forth-auto680):00977 * flag is returned.
+146C 85 (fig-forth-auto680):00978 FCB $85
+146D 44494749 (fig-forth-auto680):00979 FCC 'DIGI' ; 'DIGIT'
+1471 D4 (fig-forth-auto680):00980 FCB $D4
+1472 1461 (fig-forth-auto680):00981 FDB I-4
+1474 1476 (fig-forth-auto680):00982 DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
+1476 EC42 (fig-forth-auto680):00983 LDD NATWID,U ; Check the whole thing.
+1478 830030 (fig-forth-auto680):00984 SUBD #$30 ; ascii zero
+147B 2B22 (fig-forth-auto680):00985 BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+147D 1083000A (fig-forth-auto680):00986 CMPD #$A
+1481 2B0F (fig-forth-auto680):00987 BMI DIGIT0 IF '9' OR LESS
+1483 10830011 (fig-forth-auto680):00988 CMPD #$11
+1487 2B16 (fig-forth-auto680):00989 BMI DIGIT2 if less than 'A'
+1489 1083002B (fig-forth-auto680):00990 CMPD #$2B
+148D 2A10 (fig-forth-auto680):00991 BPL DIGIT2 if greater than 'Z'
+148F 830007 (fig-forth-auto680):00992 SUBD #7 translate 'A' thru 'F'
+1492 10A3C4 (fig-forth-auto680):00993 DIGIT0 CMPD ,U ; Check the base.
+1495 2A08 (fig-forth-auto680):00994 BPL DIGIT2 if not less than the base
+1497 ED42 (fig-forth-auto680):00995 STD NATWID,U ; Store converted digit. (High byte known zero.)
+1499 CC0001 (fig-forth-auto680):00996 LDD #1 ; set valid flag
+149C EDC4 (fig-forth-auto680):00997 DIGIT1 STD ,U ; store the flag
+149E 39 (fig-forth-auto680):00998 RTS NEXT
+149F CC0000 (fig-forth-auto680):00999 DIGIT2 LDD #0 ; set not valid flag
+14A2 3342 (fig-forth-auto680):01000 LEAU NATWID,U ; pop base
+14A4 20F6 (fig-forth-auto680):01001 BRA DIGIT1
+ (fig-forth-auto680):01002 * TFR S,X ; TSX :
+ (fig-forth-auto680):01003 * LDA 3,X
+ (fig-forth-auto680):01004 * SUBA #$30 ascii zero
+ (fig-forth-auto680):01005 * BMI DIGIT2 IF LESS THAN '0', ILLEGAL
+ (fig-forth-auto680):01006 * CMPA #$A
+ (fig-forth-auto680):01007 * BMI DIGIT0 IF '9' OR LESS
+ (fig-forth-auto680):01008 * CMPA #$11
+ (fig-forth-auto680):01009 * BMI DIGIT2 if less than 'A'
+ (fig-forth-auto680):01010 * CMPA #$2B
+ (fig-forth-auto680):01011 * BPL DIGIT2 if greater than 'Z'
+ (fig-forth-auto680):01012 * SUBA #7 translate 'A' thru 'F'
+ (fig-forth-auto680):01013 * DIGIT0 CMPA 1,X
+ (fig-forth-auto680):01014 * BPL DIGIT2 if not less than the base
+ (fig-forth-auto680):01015 * LDB #1 set flag
+ (fig-forth-auto680):01016 * STA 3,X store digit
+ (fig-forth-auto680):01017 * DIGIT1 STB 1,X store the flag
+ (fig-forth-auto680):01018 * JMP NEXT
+ (fig-forth-auto680):01019 * DIGIT2 CLRB ;
+ (fig-forth-auto680):01020 * LEAS 1,S ;
+ (fig-forth-auto680):01021 * LEAS 1,S ; pop bottom number
+ (fig-forth-auto680):01022 * TFR S,X ; TSX :
+ (fig-forth-auto680):01023 * STB 0,X make sure both bytes are 00
+ (fig-forth-auto680):01024 * BRA DIGIT1
+ (fig-forth-auto680):01025 *
+ (fig-forth-auto680):01026 * ######>> screen 19 <<
+ (fig-forth-auto680):01027 *
+ (fig-forth-auto680):01028 * The word definition format in the dictionary:
+ (fig-forth-auto680):01029 *
+ (fig-forth-auto680):01030 * (Symbol names are bracketed by bytes with the high bit set, rather than linked.)
+ (fig-forth-auto680):01031 *
+ (fig-forth-auto680):01032 * NFA (name field address):
+ (fig-forth-auto680):01033 * char-count + $80 Length of symbol name, flagged with high bit set.
+ (fig-forth-auto680):01034 * char 1 Characters of symbol name.
+ (fig-forth-auto680):01035 * char 2
+ (fig-forth-auto680):01036 * ...
+ (fig-forth-auto680):01037 * char n + $80 symbol termination flag (char set < 128 code points)
+ (fig-forth-auto680):01038 * LFA (link field address):
+ (fig-forth-auto680):01039 * link high byte \___pointer to previous word in list
+ (fig-forth-auto680):01040 * link low byte / -- Combined allocation/dictionary list. --
+ (fig-forth-auto680):01041 * CFA (code field address):
+ (fig-forth-auto680):01042 * CFA high byte \___pointer to native CPU machine code
+ (fig-forth-auto680):01043 * CFA low byte / -- Consider this the characteristic code. --
+ (fig-forth-auto680):01044 * PFA (parameter field address):
+ (fig-forth-auto680):01045 * parameter fields -- Machine code for low-level native machine CPU code,
+ (fig-forth-auto680):01046 * " instruction list for high-level Forth code,
+ (fig-forth-auto680):01047 * " constant data for constants, pointers to per task variables,
+ (fig-forth-auto680):01048 * " space for variables, for global variables, etc.
+ (fig-forth-auto680):01049 *
+ (fig-forth-auto680):01050 * In the case of native CPU machine code, the address at CFA will be PFA.
+ (fig-forth-auto680):01051
+ (fig-forth-auto680):01052 * Definition attributes:
+ 0040 (fig-forth-auto680):01053 FIMMED EQU $40 ; Immediate word flag.
+ 0020 (fig-forth-auto680):01054 FSMUDG EQU $20 ; Smudged => definition not ready.
+ 003F (fig-forth-auto680):01055 CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte.
+ (fig-forth-auto680):01056 * Note that the SMUDGE bit is not masked out.
+ (fig-forth-auto680):01057 *
+ (fig-forth-auto680):01058 * But we really want more (Thinking for a new model, need one more byte):
+ (fig-forth-auto680):01059 * FCOMPI EQU $10 ; Compile-time-only.
+ (fig-forth-auto680):01060 * FASSEM EQU $08 ; Assembly-language code only.
+ (fig-forth-auto680):01061 * F4THLV EQU $04 ; Must not be called from assembly language code.
+ (fig-forth-auto680):01062 * These would require some significant adjustments to the model.
+ (fig-forth-auto680):01063 * We also want to put the low-level VM stuff in its own vocabulary.
+ (fig-forth-auto680):01064 *
+ (fig-forth-auto680):01065 * ======>> 11 <<
+ (fig-forth-auto680):01066 * (FIND) ( name vocptr --- locptr length true )
+ (fig-forth-auto680):01067 * ( name vocptr --- false )
+ (fig-forth-auto680):01068 * Search vocabulary for a symbol called name.
+ (fig-forth-auto680):01069 * name is a pointer to a high-bit bracket string with length head.
+ (fig-forth-auto680):01070 * vocptr is a pointer to the NFA of the tail-end (LATEST) definition
+ (fig-forth-auto680):01071 * in the vocabulary to be searched.
+ (fig-forth-auto680):01072 * Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
+14A6 86 (fig-forth-auto680):01073 FCB $86
+14A7 2846494E44 (fig-forth-auto680):01074 FCC '(FIND' ; '(FIND)'
+14AC A9 (fig-forth-auto680):01075 FCB $A9
+14AD 146C (fig-forth-auto680):01076 FDB DIGIT-8
+14AF 14B1 (fig-forth-auto680):01077 PFIND FDB *+NATWID
+14B1 3420 (fig-forth-auto680):01078 PSHS Y ; Have to track two pointers.
+ (fig-forth-auto680):01079 * Use the stack and registers instead of temp area N.
+ 0002 (fig-forth-auto680):01080 PA0 EQU NATWID ; pointer to the length byte of name being searched against
+ 0000 (fig-forth-auto680):01081 PD EQU 0 ; pointer to NFA of dict word being checked
+ (fig-forth-auto680):01082 *
+ (fig-forth-auto680):01083 * INC <TRACEM
+ (fig-forth-auto680):01084 * LBSR DBGREG
+14B3 AEC4 (fig-forth-auto680):01085 LDX PD,U ; Start in on the vocabulary (NFA).
+14B5 10AE42 (fig-forth-auto680):01086 PFNDLP LDY PA0,U ; Point to the name to check against.
+14B8 E680 (fig-forth-auto680):01087 LDB ,X+ ; get dict name length byte
+14BA 1F98 (fig-forth-auto680):01088 TFR B,A ; Save it in case it matches.
+14BC C43F (fig-forth-auto680):01089 ANDB #CTMASK
+ (fig-forth-auto680):01090 * LBSR DBGREG
+14BE E1A0 (fig-forth-auto680):01091 CMPB ,Y+ ; Compare lengths
+ (fig-forth-auto680):01092 * LBSR DBGREG
+14C0 261C (fig-forth-auto680):01093 BNE PFNDUN
+14C2 E680 (fig-forth-auto680):01094 PFNDBR LDB ,X+
+14C4 5D (fig-forth-auto680):01095 TSTB ; ; Is high bit of character in dictionary entry set?
+ (fig-forth-auto680):01096 * LBSR DBGREG
+14C5 2A13 (fig-forth-auto680):01097 BPL PFNDCH
+ (fig-forth-auto680):01098 * LBSR DBGREG
+14C7 C47F (fig-forth-auto680):01099 ANDB #$7F ; Clear high bit from dictionary.
+14C9 E1A0 (fig-forth-auto680):01100 CMPB ,Y+ ; Compare "last" characters.
+ (fig-forth-auto680):01101 * LBSR DBGREG
+14CB 2717 (fig-forth-auto680):01102 BEQ FOUND ; Matches even if dictionary actual length is shorter.
+14CD AE81 (fig-forth-auto680):01103 PFNDLN LDX ,X++ ; Get previous link in vocabulary.
+ (fig-forth-auto680):01104 * LBSR DBGREG
+14CF 26E4 (fig-forth-auto680):01105 BNE PFNDLP ; Continue if link not=0
+ (fig-forth-auto680):01106 *
+ (fig-forth-auto680):01107 * not found :
+14D1 3342 (fig-forth-auto680):01108 LEAU NATWID,U ; Return only false flag.
+14D3 CC0000 (fig-forth-auto680):01109 LDD #0
+14D6 EDC4 (fig-forth-auto680):01110 STD ,U
+ (fig-forth-auto680):01111 * LBSR DBGREG
+ (fig-forth-auto680):01112 * DEC <TRACEM
+14D8 35A0 (fig-forth-auto680):01113 PULS Y,PC
+ (fig-forth-auto680):01114 *
+14DA E1A0 (fig-forth-auto680):01115 PFNDCH CMPB ,Y+ ; Compare characters.
+ (fig-forth-auto680):01116 * LBSR DBGREG
+14DC 27E4 (fig-forth-auto680):01117 BEQ PFNDBR
+14DE (fig-forth-auto680):01118 PFNDUN
+14DE E680 (fig-forth-auto680):01119 PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
+ (fig-forth-auto680):01120 * LBSR DBGREG
+14E0 2AFC (fig-forth-auto680):01121 BPL PFNDSC
+ (fig-forth-auto680):01122 * LBSR DBGREG
+14E2 20E9 (fig-forth-auto680):01123 BRA PFNDLN
+ (fig-forth-auto680):01124 *
+ (fig-forth-auto680):01125 * found :
+ (fig-forth-auto680):01126 *
+14E4 3004 (fig-forth-auto680):01127 FOUND LEAX 2*NATWID,X
+ (fig-forth-auto680):01128 * LBSR DBGREG
+14E6 AF42 (fig-forth-auto680):01129 STX NATWID,U
+14E8 1F89 (fig-forth-auto680):01130 TFR A,B
+14EA 4F (fig-forth-auto680):01131 CLRA
+14EB EDC4 (fig-forth-auto680):01132 STD ,U
+ (fig-forth-auto680):01133 * LBSR DBGREG
+14ED C601 (fig-forth-auto680):01134 LDB #1
+14EF 3606 (fig-forth-auto680):01135 PSHU A,B
+ (fig-forth-auto680):01136 * LBSR DBGREG
+ (fig-forth-auto680):01137 * DEC <TRACEM
+14F1 35A0 (fig-forth-auto680):01138 PULS Y,PC
+ (fig-forth-auto680):01139 *
+ (fig-forth-auto680):01140 * 6800 model:
+ (fig-forth-auto680):01141 * NOP ; Probably leftovers from a debugging session.
+ (fig-forth-auto680):01142 * NOP
+ (fig-forth-auto680):01143 * PD EQU N ptr to dict word being checked
+ (fig-forth-auto680):01144 * PA0 EQU N+2
+ (fig-forth-auto680):01145 * PA EQU N+4
+ (fig-forth-auto680):01146 * PC EQU N+6
+ (fig-forth-auto680):01147 * LDX #PD
+ (fig-forth-auto680):01148 * LDB #4
+ (fig-forth-auto680):01149 * PFIND0 PULS A ; loop to get arguments
+ (fig-forth-auto680):01150 * STA 0,X
+ (fig-forth-auto680):01151 * LEAX 1,X ;
+ (fig-forth-auto680):01152 * DECB ;
+ (fig-forth-auto680):01153 * BNE PFIND0
+ (fig-forth-auto680):01154 *
+ (fig-forth-auto680):01155 * LDX PD
+ (fig-forth-auto680):01156 * PFNDLP LDB 0,X get count dict count
+ (fig-forth-auto680):01157 * STB PC
+ (fig-forth-auto680):01158 * ANDB #$3F
+ (fig-forth-auto680):01159 * LEAX 1,X ;
+ (fig-forth-auto680):01160 * STX PD update PD
+ (fig-forth-auto680):01161 * LDX PA0
+ (fig-forth-auto680):01162 * LDA 0,X get count from arg
+ (fig-forth-auto680):01163 * LEAX 1,X ;
+ (fig-forth-auto680):01164 * STX PA intialize PA
+ (fig-forth-auto680):01165 * PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01166 * CMPA ,S+ ; compare lengths
+ (fig-forth-auto680):01167 * BNE PFNDUN
+ (fig-forth-auto680):01168 * PFNDBR LDX PA
+ (fig-forth-auto680):01169 * LDA 0,X
+ (fig-forth-auto680):01170 * LEAX 1,X ;
+ (fig-forth-auto680):01171 * STX PA
+ (fig-forth-auto680):01172 * LDX PD
+ (fig-forth-auto680):01173 * LDB 0,X
+ (fig-forth-auto680):01174 * LEAX 1,X ;
+ (fig-forth-auto680):01175 * STX PD
+ (fig-forth-auto680):01176 * TSTB ; is dict entry neg. ?
+ (fig-forth-auto680):01177 * BPL PFNDCH
+ (fig-forth-auto680):01178 * ANDB #$7F clear sign
+ (fig-forth-auto680):01179 * PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01180 * CMPA ,S+ ;
+ (fig-forth-auto680):01181 * BEQ FOUND
+ (fig-forth-auto680):01182 * PFNDLN LDX 0,X get new link
+ (fig-forth-auto680):01183 * BNE PFNDLP continue if link not=0
+ (fig-forth-auto680):01184 *
+ (fig-forth-auto680):01185 * not found :
+ (fig-forth-auto680):01186 *
+ (fig-forth-auto680):01187 * CLRA ;
+ (fig-forth-auto680):01188 * CLRB ;
+ (fig-forth-auto680):01189 * JMP PUSHBA
+ (fig-forth-auto680):01190 * PFNDCH PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01191 * CMPA ,S+ ;
+ (fig-forth-auto680):01192 * BEQ PFNDBR
+ (fig-forth-auto680):01193 * PFNDUN LDX PD
+ (fig-forth-auto680):01194 * PFNDSC LDB 0,X scan forward to end of this name
+ (fig-forth-auto680):01195 * LEAX 1,X ;
+ (fig-forth-auto680):01196 * BPL PFNDSC
+ (fig-forth-auto680):01197 * BRA PFNDLN
+ (fig-forth-auto680):01198 *
+ (fig-forth-auto680):01199 * found :
+ (fig-forth-auto680):01200 *
+ (fig-forth-auto680):01201 * FOUND LDA PD compute CFA
+ (fig-forth-auto680):01202 * LDB PD+1
+ (fig-forth-auto680):01203 * ADDB #4
+ (fig-forth-auto680):01204 * ADCA #0
+ (fig-forth-auto680):01205 * PSHS B ;
+ (fig-forth-auto680):01206 * PSHS A ;
+ (fig-forth-auto680):01207 * LDA PC
+ (fig-forth-auto680):01208 * PSHS A ;
+ (fig-forth-auto680):01209 * CLRA ;
+ (fig-forth-auto680):01210 * PSHS A ;
+ (fig-forth-auto680):01211 * LDB #1
+ (fig-forth-auto680):01212 * JMP PUSHBA
+ (fig-forth-auto680):01213 *
+ (fig-forth-auto680):01214 * PSHS A ; Left over from a stray copy-paste, I guess.
+ (fig-forth-auto680):01215 * CLRA ;
+ (fig-forth-auto680):01216 * PSHS A ;
+ (fig-forth-auto680):01217 * LDB #1
+ (fig-forth-auto680):01218 * JMP PUSHBA
+ (fig-forth-auto680):01219 *
+ (fig-forth-auto680):01220 * ######>> screen 20 <<
+ (fig-forth-auto680):01221 * ======>> 12 <<
+ (fig-forth-auto680):01222 * ( buffer ch --- buffer symboloffset delimiteroffset scancount )
+ (fig-forth-auto680):01223 * ( buffer ch --- buffer symboloffset nuloffset scancount ) ( Scan count == nuloffset )
+ (fig-forth-auto680):01224 * ( buffer ch --- buffer nuloffset onepast scancount )
+ (fig-forth-auto680):01225 * Scan buffer for a symbol delimited by ch or ASCII NUL,
+ (fig-forth-auto680):01226 * return the length of the buffer region scanned,
+ (fig-forth-auto680):01227 * the offset to the trailing delimiter,
+ (fig-forth-auto680):01228 * and the offset of the first character of the symbol.
+ (fig-forth-auto680):01229 * Leave the buffer on the stack.
+ (fig-forth-auto680):01230 * Scancount is also offset to first character not yet looked at.
+ (fig-forth-auto680):01231 * If no symbol in buffer, scancount and symboloffset point to NUL
+ (fig-forth-auto680):01232 * and delimiteroffset points one beyond for some reason.
+ (fig-forth-auto680):01233 * On trailing NUL, delimiteroffset == scancount.
+ (fig-forth-auto680):01234 * (Buffer is the address of the buffer array to scan.)
+ (fig-forth-auto680):01235 * (This is a bit too tricky, really.)
+14F3 87 (fig-forth-auto680):01236 FCB $87
+14F4 454E434C4F53 (fig-forth-auto680):01237 FCC 'ENCLOS' ; 'ENCLOSE'
+14FA C5 (fig-forth-auto680):01238 FCB $C5
+14FB 14A6 (fig-forth-auto680):01239 FDB PFIND-9
+14FD 14FF (fig-forth-auto680):01240 ENCLOS FDB *+NATWID
+14FF A641 (fig-forth-auto680):01241 LDA 1,U ; Delimiter character to match against in A.
+1501 AE42 (fig-forth-auto680):01242 LDX NATWID,U ; Buffer to scan in.
+1503 5F (fig-forth-auto680):01243 CLRB ; Initialize offset. (Buffer < 256 wide!)
+ (fig-forth-auto680):01244 * Scan to a non-delimiter or a NUL
+1504 6D85 (fig-forth-auto680):01245 ENCDEL TST B,X ; NUL ?
+1506 271F (fig-forth-auto680):01246 BEQ ENCNUL
+1508 A185 (fig-forth-auto680):01247 CMPA B,X ; Delimiter?
+150A 2603 (fig-forth-auto680):01248 BNE ENC1ST
+150C 5C (fig-forth-auto680):01249 INCB ; count character
+150D 20F5 (fig-forth-auto680):01250 BRA ENCDEL
+ (fig-forth-auto680):01251 * Found first character. Save the offset.
+150F E741 (fig-forth-auto680):01252 ENC1ST STB 1,U ; Found first non-delimiter character --
+1511 6FC4 (fig-forth-auto680):01253 CLR ,U ; store the count, zero high byte.
+ (fig-forth-auto680):01254 * Scan to a delimiter or a NUL
+1513 6D85 (fig-forth-auto680):01255 ENCSYM TST B,X ; NUL ?
+1515 271E (fig-forth-auto680):01256 BEQ ENC0TR
+1517 A185 (fig-forth-auto680):01257 CMPA B,X ; delimiter?
+1519 2703 (fig-forth-auto680):01258 BEQ ENCEND
+151B 5C (fig-forth-auto680):01259 INCB
+151C 20F5 (fig-forth-auto680):01260 BRA ENCSYM
+ (fig-forth-auto680):01261 * Found end of symbol. Push offset to delimiter found.
+151E 4F (fig-forth-auto680):01262 ENCEND CLRA ; high byte -- buffer < 255 wide!
+151F 3606 (fig-forth-auto680):01263 PSHU A,B ; Offset to seen delimiter.
+ (fig-forth-auto680):01264 * Advance and push address of next character to check.
+1521 C30001 (fig-forth-auto680):01265 ADDD #1 ; In case offset was 255.
+1524 3606 (fig-forth-auto680):01266 PSHU A,B
+1526 39 (fig-forth-auto680):01267 RTS
+ (fig-forth-auto680):01268 * Found NUL before non-delimiter, therefore there is no word
+1527 4F (fig-forth-auto680):01269 ENCNUL CLRA ; high byte -- buffer < 255 wide!
+1528 EDC4 (fig-forth-auto680):01270 STD ,U ; offset to NUL.
+152A C30001 (fig-forth-auto680):01271 ADDD #1 ; Point after NUL to allow (FIND) to match it.
+152D 3606 (fig-forth-auto680):01272 PSHU A,B ;
+152F 830001 (fig-forth-auto680):01273 SUBD #1 ; Next is not passed NUL.
+1532 3606 (fig-forth-auto680):01274 PSHU A,B ; Stealing code will save only one byte.
+1534 39 (fig-forth-auto680):01275 RTS
+ (fig-forth-auto680):01276 * Found NUL following the word instead of delimiter.
+1535 (fig-forth-auto680):01277 ENC0TR
+ (fig-forth-auto680):01278 * INC <TRACEM
+ (fig-forth-auto680):01279 * LBSR DBGREG
+1535 4F (fig-forth-auto680):01280 CLRA
+1536 3606 (fig-forth-auto680):01281 PSHU A,B ; Save offset to first after symbol (NUL)
+ (fig-forth-auto680):01282 * LBSR DBGREG
+1538 3606 (fig-forth-auto680):01283 PSHU A,B ; and count scanned.
+ (fig-forth-auto680):01284 * LBSR DBGREG
+ (fig-forth-auto680):01285 * DEC <TRACEM
+153A 39 (fig-forth-auto680):01286 RTS
+ (fig-forth-auto680):01287 * NOTE :
+ (fig-forth-auto680):01288 * FC means offset (bytes) to First Character of next word
+ (fig-forth-auto680):01289 * EW " " to End of Word
+ (fig-forth-auto680):01290 * NC " " to Next Character to start next enclose at
+ (fig-forth-auto680):01291 * ENCLOS FDB *+NATWID
+ (fig-forth-auto680):01292 * LEAS 1,S ;
+ (fig-forth-auto680):01293 * PULS B ; now, get the low byte, for an 8-bit delimiter
+ (fig-forth-auto680):01294 * TFR S,X ; TSX :
+ (fig-forth-auto680):01295 * LDX 0,X
+ (fig-forth-auto680):01296 * CLR N
+ (fig-forth-auto680):01297 * * wait for a non-delimiter or a NUL
+ (fig-forth-auto680):01298 * ENCDEL LDA 0,X
+ (fig-forth-auto680):01299 * BEQ ENCNUL
+ (fig-forth-auto680):01300 * PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01301 * CMPA ,S+ ; CHECK FOR DELIM
+ (fig-forth-auto680):01302 * BNE ENC1ST
+ (fig-forth-auto680):01303 * LEAX 1,X ;
+ (fig-forth-auto680):01304 * INC N
+ (fig-forth-auto680):01305 * BRA ENCDEL
+ (fig-forth-auto680):01306 * * found first character. Push FC
+ (fig-forth-auto680):01307 * ENC1ST LDA N found first char.
+ (fig-forth-auto680):01308 * PSHS A ;
+ (fig-forth-auto680):01309 * CLRA ;
+ (fig-forth-auto680):01310 * PSHS A ;
+ (fig-forth-auto680):01311 * wait for a delimiter or a NUL
+ (fig-forth-auto680):01312 * ENCSYM LDA 0,X
+ (fig-forth-auto680):01313 * BEQ ENC0TR
+ (fig-forth-auto680):01314 * PSHS B ; ** emulating CBA:
+ (fig-forth-auto680):01315 * CMPA ,S+ ; ckech for delim.
+ (fig-forth-auto680):01316 * BEQ ENCEND
+ (fig-forth-auto680):01317 * LEAX 1,X ;
+ (fig-forth-auto680):01318 * INC N
+ (fig-forth-auto680):01319 * BRA ENCSYM
+ (fig-forth-auto680):01320 * * found EW. Push it
+ (fig-forth-auto680):01321 * ENCEND LDB N
+ (fig-forth-auto680):01322 * CLRA ;
+ (fig-forth-auto680):01323 * PSHS B ;
+ (fig-forth-auto680):01324 * PSHS A ;
+ (fig-forth-auto680):01325 * * advance and push NC
+ (fig-forth-auto680):01326 * INCB ;
+ (fig-forth-auto680):01327 * JMP PUSHBA
+ (fig-forth-auto680):01328 * found NUL before non-delimiter, therefore there is no word
+ (fig-forth-auto680):01329 * ENCNUL LDB N found NUL
+ (fig-forth-auto680):01330 * PSHS B ;
+ (fig-forth-auto680):01331 * PSHS A ;
+ (fig-forth-auto680):01332 * INCB ;
+ (fig-forth-auto680):01333 * BRA ENC0TR+2 ; ********** POTENTIAL BUG HERE *******
+ (fig-forth-auto680):01334 * ******** Should use labels in case opcodes change! ********
+ (fig-forth-auto680):01335 * found NUL following the word instead of SPACE
+ (fig-forth-auto680):01336 * ENC0TR LDB N
+ (fig-forth-auto680):01337 * PSHS B ; save EW
+ (fig-forth-auto680):01338 * PSHS A ;
+ (fig-forth-auto680):01339 * ENCL8 LDB N save NC
+ (fig-forth-auto680):01340 * JMP PUSHBA
+ (fig-forth-auto680):01341
+ (fig-forth-auto680):01342 PAGE
+ (fig-forth-auto680):01343 *
+ (fig-forth-auto680):01344 * ######>> screen 21 <<
+ (fig-forth-auto680):01345 * The next 4 words call system dependant I/O routines
+ (fig-forth-auto680):01346 * which are listed after word "-->" ( lable: "arrow" )
+ (fig-forth-auto680):01347 * in the dictionary.
+ (fig-forth-auto680):01348 *
+ (fig-forth-auto680):01349 * ======>> 13 <<
+ (fig-forth-auto680):01350 * ( c --- )
+ (fig-forth-auto680):01351 * Write c to the output device (screen or printer).
+ (fig-forth-auto680):01352 * ROM Uses the ECB device number at address $6F,
+ (fig-forth-auto680):01353 * -2 is printer, 0 is screen.
+153B 84 (fig-forth-auto680):01354 FCB $84
+153C 454D49 (fig-forth-auto680):01355 FCC 'EMI' ; 'EMIT'
+153F D4 (fig-forth-auto680):01356 FCB $D4
+1540 14F3 (fig-forth-auto680):01357 FDB ENCLOS-10
+1542 1544 (fig-forth-auto680):01358 EMIT FDB *+NATWID
+1544 3706 (fig-forth-auto680):01359 PULU D
+1546 171067 (fig-forth-auto680):01360 LBSR PEMIT ; PEMIT expects the character in D.
+1549 0C33 (fig-forth-auto680):01361 INC <XOUT+1
+154B 2602 (fig-forth-auto680):01362 BNE EMITDN
+154D 0C32 (fig-forth-auto680):01363 INC <XOUT
+154F 39 (fig-forth-auto680):01364 EMITDN RTS
+ (fig-forth-auto680):01365 * PULS A ;
+ (fig-forth-auto680):01366 * PULS A ;
+ (fig-forth-auto680):01367 * JSR PEMIT
+ (fig-forth-auto680):01368 * LDX UP
+ (fig-forth-auto680):01369 * INC XOUT+1-UORIG,X
+ (fig-forth-auto680):01370 * BNE *+4 ;
+ (fig-forth-auto680):01371 * ****WARNING**** HARD OFFSET: *+4 ****
+ (fig-forth-auto680):01372 * INC XOUT-UORIG,X
+ (fig-forth-auto680):01373 * JMP NEXT
+ (fig-forth-auto680):01374 *
+ (fig-forth-auto680):01375 * ======>> 14 <<
+ (fig-forth-auto680):01376 * ( --- c )
+ (fig-forth-auto680):01377 * ( --- BREAK )
+ (fig-forth-auto680):01378 * Wait for a key from the keyboard.
+ (fig-forth-auto680):01379 * If the key is BREAK, set the high byte (result $FF03).
+1550 83 (fig-forth-auto680):01380 FCB $83
+1551 4B45 (fig-forth-auto680):01381 FCC 'KE' ; 'KEY'
+1553 D9 (fig-forth-auto680):01382 FCB $D9
+1554 153B (fig-forth-auto680):01383 FDB EMIT-7
+1556 1558 (fig-forth-auto680):01384 KEY FDB *+NATWID
+1558 171062 (fig-forth-auto680):01385 LBSR PKEY ; PKEY leaves the key/break code in D.
+155B 3606 (fig-forth-auto680):01386 PSHU D
+155D 39 (fig-forth-auto680):01387 RTS
+ (fig-forth-auto680):01388 * JSR PKEY
+ (fig-forth-auto680):01389 * PSHS A ;
+ (fig-forth-auto680):01390 * CLRA ;
+ (fig-forth-auto680):01391 * PSHS A ;
+ (fig-forth-auto680):01392 * JMP NEXT
+ (fig-forth-auto680):01393 *
+ (fig-forth-auto680):01394 * ======>> 15 <<
+ (fig-forth-auto680):01395 * ( --- f )
+ (fig-forth-auto680):01396 * Scan keyboard, but do not wait.
+ (fig-forth-auto680):01397 * Return 0 if no key,
+ (fig-forth-auto680):01398 * BREAK ($ff03) if BREAK is pressed,
+ (fig-forth-auto680):01399 * or key currently pressed.
+155E 89 (fig-forth-auto680):01400 FCB $89
+155F 3F5445524D494E41 (fig-forth-auto680):01401 FCC '?TERMINA' ; '?TERMINAL'
+1567 CC (fig-forth-auto680):01402 FCB $CC
+1568 1550 (fig-forth-auto680):01403 FDB KEY-6
+156A 156C (fig-forth-auto680):01404 QTERM FDB *+NATWID
+156C 171073 (fig-forth-auto680):01405 LBSR PQTER ; PQTER leaves the flag/key in D.
+156F 3606 (fig-forth-auto680):01406 PSHU D
+1571 39 (fig-forth-auto680):01407 RTS
+ (fig-forth-auto680):01408 * JSR PQTER
+ (fig-forth-auto680):01409 * CLRB ;
+ (fig-forth-auto680):01410 * JMP PUSHBA stack the flag
+ (fig-forth-auto680):01411 *
+ (fig-forth-auto680):01412 * ======>> 16 <<
+ (fig-forth-auto680):01413 * ( --- )
+ (fig-forth-auto680):01414 * EMIT a Carriage Return (ASCII CR).
+1572 82 (fig-forth-auto680):01415 FCB $82
+1573 43 (fig-forth-auto680):01416 FCC 'C' ; 'CR'
+1574 D2 (fig-forth-auto680):01417 FCB $D2
+1575 155E (fig-forth-auto680):01418 FDB QTERM-12
+1577 1579 (fig-forth-auto680):01419 CR FDB *+NATWID
+1579 161071 (fig-forth-auto680):01420 LBRA PCR ; Nothing really to do here.
+ (fig-forth-auto680):01421 * JSR PCR
+ (fig-forth-auto680):01422 * JMP NEXT
+ (fig-forth-auto680):01423 *
+ (fig-forth-auto680):01424 * ######>> screen 22 <<
+ (fig-forth-auto680):01425 * ======>> 17 <<
+ (fig-forth-auto680):01426 * ( source target count --- )
+ (fig-forth-auto680):01427 * Copy/move count bytes from source to target.
+ (fig-forth-auto680):01428 * Moves ascending addresses,
+ (fig-forth-auto680):01429 * so that overlapping only works if the source is above the destination.
+157C 85 (fig-forth-auto680):01430 FCB $85
+157D 434D4F56 (fig-forth-auto680):01431 FCC 'CMOV' ; 'CMOVE' : source, destination, count
+1581 C5 (fig-forth-auto680):01432 FCB $C5
+1582 1572 (fig-forth-auto680):01433 FDB CR-5
+1584 1586 (fig-forth-auto680):01434 CMOVE FDB *+NATWID
+1586 3420 (fig-forth-auto680):01435 PSHS Y ;
+ (fig-forth-auto680):01436 * INC <TRACEM
+ (fig-forth-auto680):01437 * LBSR DBGREG
+1588 AE42 (fig-forth-auto680):01438 LDX 1*NATWID,U
+158A 10AE44 (fig-forth-auto680):01439 LDY 2*NATWID,U
+158D 2004 (fig-forth-auto680):01440 BRA CMOVLE ;
+158F (fig-forth-auto680):01441 CMOVLP
+ (fig-forth-auto680):01442 * LBSR DBGREG
+158F A6A0 (fig-forth-auto680):01443 LDA ,Y+
+1591 A780 (fig-forth-auto680):01444 STA ,X+
+ (fig-forth-auto680):01445 * LBSR DBGREG
+1593 (fig-forth-auto680):01446 CMOVLE
+1593 ECC4 (fig-forth-auto680):01447 LDD ,U
+1595 830001 (fig-forth-auto680):01448 SUBD #1
+1598 EDC4 (fig-forth-auto680):01449 STD ,U
+159A 24F3 (fig-forth-auto680):01450 BCC CMOVLP
+159C 3346 (fig-forth-auto680):01451 LEAU 3*NATWID,U
+ (fig-forth-auto680):01452 * DEC <TRACEM
+159E 35A0 (fig-forth-auto680):01453 PULS Y,PC
+ (fig-forth-auto680):01454 * One way: ; takes ( 37+17*count+9*(count/256) cycles )
+ (fig-forth-auto680):01455 * PSHS Y ; #2~7 ; Gotta have our pointers.
+ (fig-forth-auto680):01456 * INC <TRACEM
+ (fig-forth-auto680):01457 * LBSR DBGREG
+ (fig-forth-auto680):01458 * PULU D,X,Y ; #2~11
+ (fig-forth-auto680):01459 * PSHS A ; #2~6 ; Gotta have our pointers.
+ (fig-forth-auto680):01460 * BRA CMOVLE ; #2~3
+ (fig-forth-auto680):01461 * CMOVLP
+ (fig-forth-auto680):01462 * LBSR DBGREG
+ (fig-forth-auto680):01463 * LDA ,Y+ ; #2~6
+ (fig-forth-auto680):01464 * STA ,X+ ; #2~6
+ (fig-forth-auto680):01465 * LBSR DBGREG
+ (fig-forth-auto680):01466 * CMOVLE
+ (fig-forth-auto680):01467 * SUBB #1 ; #2~2
+ (fig-forth-auto680):01468 * BCC CMOVLP ; #2~3
+ (fig-forth-auto680):01469 * DEC ,S ; #2=6
+ (fig-forth-auto680):01470 * BPL CMOVLP ; #2~3
+ (fig-forth-auto680):01471 * DEC <TRACEM
+ (fig-forth-auto680):01472 * PULS A,Y,PC ; #2~10
+ (fig-forth-auto680):01473 * Another way ; takes ( 42+17*count+9*(count/256) cycles )
+ (fig-forth-auto680):01474 * LDD #0 ; #3~3
+ (fig-forth-auto680):01475 * SUBD ,U++ ; #2~9 ; invert the count
+ (fig-forth-auto680):01476 * PSHS A,Y ; #2~8
+ (fig-forth-auto680):01477 * PULU X,Y ; #2~9
+ (fig-forth-auto680):01478 * BEQ CMOVEX ; #2~3
+ (fig-forth-auto680):01479 * CMOVEL
+ (fig-forth-auto680):01480 * LDA ,Y+ ; #2~6
+ (fig-forth-auto680):01481 * STA ,X+ ; #2~6
+ (fig-forth-auto680):01482 * INCB ; #1~2
+ (fig-forth-auto680):01483 * BNE CMOVEL ; #2~3
+ (fig-forth-auto680):01484 * INC ,S ; #2~6
+ (fig-forth-auto680):01485 * BNE CMOVEL ; #2~3
+ (fig-forth-auto680):01486 * CMOVEX
+ (fig-forth-auto680):01487 * PULS A,Y,PC ; #2~10
+ (fig-forth-auto680):01488 * Yet another way ; takes ( 37+29*count cycles )
+ (fig-forth-auto680):01489 * PSHS Y ; #2~7
+ (fig-forth-auto680):01490 * LDX NATWID,U ; #2~6
+ (fig-forth-auto680):01491 * LDY NATWID,U ; #3~7
+ (fig-forth-auto680):01492 * BRA CMOVLE ; #2~3
+ (fig-forth-auto680):01493 * CMOVLP
+ (fig-forth-auto680):01494 * LDA ,Y+ ; #2~6
+ (fig-forth-auto680):01495 * STA ,X+ ; #2~6
+ (fig-forth-auto680):01496 * CMOVLE
+ (fig-forth-auto680):01497 * LDD ,U ; #2~5
+ (fig-forth-auto680):01498 * SUBD #1 ; #3~4
+ (fig-forth-auto680):01499 * STD ,U ; #2~5
+ (fig-forth-auto680):01500 * BPL CMOVLP ; #2~3
+ (fig-forth-auto680):01501 * LEAU 3*NATWID,U ; #2~5
+ (fig-forth-auto680):01502 * PULS Y,PC ; #2~9
+ (fig-forth-auto680):01503 * Yet another way ; takes ( 44+24*odd+33*count/2 cycles )
+ (fig-forth-auto680):01504 * PSHS Y ; #2~7
+ (fig-forth-auto680):01505 * LDX NATWID,U ; #2~6
+ (fig-forth-auto680):01506 * LDY 2*NATWID,U ; #3~7
+ (fig-forth-auto680):01507 * LDD ,U ; #2~5
+ (fig-forth-auto680):01508 * BITB #1 ; #2~2
+ (fig-forth-auto680):01509 * BEQ CMOVLE ; #2~3
+ (fig-forth-auto680):01510 * SUBD #1 ; #3~4
+ (fig-forth-auto680):01511 * STD ,U ; #2~5
+ (fig-forth-auto680):01512 * LDA ,Y+ ; #2~6
+ (fig-forth-auto680):01513 * STA ,X+ ; #2~6
+ (fig-forth-auto680):01514 * BRA CMOVLE ; #2~3
+ (fig-forth-auto680):01515 * CMOVLP
+ (fig-forth-auto680):01516 * LDD ,Y++ ; #2~8
+ (fig-forth-auto680):01517 * STD ,X++ ; #2~8
+ (fig-forth-auto680):01518 * CMOVLI
+ (fig-forth-auto680):01519 * LDD ,U ; #2~5
+ (fig-forth-auto680):01520 * CMOVLE
+ (fig-forth-auto680):01521 * SUBD #2 ; #3~4
+ (fig-forth-auto680):01522 * STD ,U ; #2~5
+ (fig-forth-auto680):01523 * BPL CMOVLP ; #2~3
+ (fig-forth-auto680):01524 * LEAU 3*NATWID,U ; #2~5
+ (fig-forth-auto680):01525 * PULS Y,PC ; #2~9
+ (fig-forth-auto680):01526 * From the 6800 model:
+ (fig-forth-auto680):01527 * CMOVE FDB *+2 takes ( 43+47*count cycles ) on 6800
+ (fig-forth-auto680):01528 * LDX #N
+ (fig-forth-auto680):01529 * LDB #6
+ (fig-forth-auto680):01530 * CMOV1 PULS A ;
+ (fig-forth-auto680):01531 * STA 0,X move parameters to scratch area
+ (fig-forth-auto680):01532 * LEAX 1,X ;
+ (fig-forth-auto680):01533 * DECB ;
+ (fig-forth-auto680):01534 * BNE CMOV1
+ (fig-forth-auto680):01535 * CMOV2 LDA N
+ (fig-forth-auto680):01536 * LDB N+1
+ (fig-forth-auto680):01537 * SUBB #1
+ (fig-forth-auto680):01538 * SBCA #0
+ (fig-forth-auto680):01539 * STA N
+ (fig-forth-auto680):01540 * STB N+1
+ (fig-forth-auto680):01541 * BCS CMOV3
+ (fig-forth-auto680):01542 * LDX N+4
+ (fig-forth-auto680):01543 * LDA 0,X
+ (fig-forth-auto680):01544 * LEAX 1,X ;
+ (fig-forth-auto680):01545 * STX N+4
+ (fig-forth-auto680):01546 * LDX N+2
+ (fig-forth-auto680):01547 * STA 0,X
+ (fig-forth-auto680):01548 * LEAX 1,X ;
+ (fig-forth-auto680):01549 * STX N+2
+ (fig-forth-auto680):01550 * BRA CMOV2
+ (fig-forth-auto680):01551 * CMOV3 JMP NEXT
+ (fig-forth-auto680):01552 *
+ (fig-forth-auto680):01553 * ######>> screen 23 <<
+ (fig-forth-auto680):01554 * ======>> 18 <<
+ (fig-forth-auto680):01555 * ( u1 u2 --- ud )
+ (fig-forth-auto680):01556 * Multiplies the top two unsigned integers,
+ (fig-forth-auto680):01557 * yielding a double integer product.
+15A0 82 (fig-forth-auto680):01558 FCB $82
+15A1 55 (fig-forth-auto680):01559 FCC 'U' ; 'U*'
+15A2 AA (fig-forth-auto680):01560 FCB $AA
+15A3 157C (fig-forth-auto680):01561 FDB CMOVE-8
+15A5 15A7 (fig-forth-auto680):01562 USTAR FDB *+NATWID
+15A7 335C (fig-forth-auto680):01563 LEAU -2*NATWID,U
+15A9 A645 (fig-forth-auto680):01564 LDA 2*NATWID+1,U ; least
+15AB E647 (fig-forth-auto680):01565 LDB 3*NATWID+1,U
+15AD 3D (fig-forth-auto680):01566 MUL
+15AE ED42 (fig-forth-auto680):01567 STD NATWID,U
+15B0 A644 (fig-forth-auto680):01568 LDA 2*NATWID,U ; most
+15B2 E646 (fig-forth-auto680):01569 LDB 3*NATWID,U
+15B4 3D (fig-forth-auto680):01570 MUL
+15B5 EDC4 (fig-forth-auto680):01571 STD ,U
+15B7 EC45 (fig-forth-auto680):01572 LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi)
+15B9 3D (fig-forth-auto680):01573 MUL
+15BA E341 (fig-forth-auto680):01574 ADDD 1,U
+15BC 2402 (fig-forth-auto680):01575 BCC USTAR3
+15BE 6CC4 (fig-forth-auto680):01576 INC ,U
+15C0 ED41 (fig-forth-auto680):01577 USTAR3 STD 1,U
+15C2 A644 (fig-forth-auto680):01578 LDA 2*NATWID,U ; second inner (u2 hi)
+15C4 E646 (fig-forth-auto680):01579 LDB 3*NATWID,U ; (u1 lo)
+15C6 3D (fig-forth-auto680):01580 MUL
+15C7 E341 (fig-forth-auto680):01581 ADDD 1,U
+15C9 2402 (fig-forth-auto680):01582 BCC USTAR4
+15CB 6CC4 (fig-forth-auto680):01583 INC ,U
+15CD ED41 (fig-forth-auto680):01584 USTAR4 STD 1,U
+15CF 3716 (fig-forth-auto680):01585 PULU D,X
+15D1 EDC4 (fig-forth-auto680):01586 STD ,U
+15D3 AF42 (fig-forth-auto680):01587 STX NATWID,U
+15D5 39 (fig-forth-auto680):01588 RTS
+ (fig-forth-auto680):01589 *
+ (fig-forth-auto680):01590 * from 6800 model:
+ (fig-forth-auto680):01591 * BSR USTARS
+ (fig-forth-auto680):01592 * LEAS 1,S ;
+ (fig-forth-auto680):01593 * LEAS 1,S ;
+ (fig-forth-auto680):01594 * JMP PUSHBA
+ (fig-forth-auto680):01595 *
+ (fig-forth-auto680):01596 * The following is a subroutine which
+ (fig-forth-auto680):01597 * multiplies top 2 words on stack,
+ (fig-forth-auto680):01598 * leaving 32-bit result: high order word in A,B
+ (fig-forth-auto680):01599 * low order word in 2nd word of stack.
+ (fig-forth-auto680):01600 *
+ (fig-forth-auto680):01601 * USTARS LDA #16 bits/word counter
+ (fig-forth-auto680):01602 * PSHS A ;
+ (fig-forth-auto680):01603 * CLRA ;
+ (fig-forth-auto680):01604 * CLRB ;
+ (fig-forth-auto680):01605 * TFR S,X ; TSX :
+ (fig-forth-auto680):01606 * USTAR2 ROR 5,X shift multiplier
+ (fig-forth-auto680):01607 * ROR 6,X
+ (fig-forth-auto680):01608 * DEC 0,X done?
+ (fig-forth-auto680):01609 * BMI USTAR4
+ (fig-forth-auto680):01610 * BCC USTAR3
+ (fig-forth-auto680):01611 * ADDB 4,X
+ (fig-forth-auto680):01612 * ADCA 3,X
+ (fig-forth-auto680):01613 * USTAR3 RORA ;
+ (fig-forth-auto680):01614 * RORB ; shift result
+ (fig-forth-auto680):01615 * BRA USTAR2
+ (fig-forth-auto680):01616 * USTAR4 LEAS 1,S ; dump counter
+ (fig-forth-auto680):01617 * RTS
+ (fig-forth-auto680):01618 *
+ (fig-forth-auto680):01619 * ######>> screen 24 <<
+ (fig-forth-auto680):01620 * ======>> 19 <<
+ (fig-forth-auto680):01621 * ( ud u --- uremainder uquotient )
+ (fig-forth-auto680):01622 * Divides the top unsigned integer
+ (fig-forth-auto680):01623 * into the second and third words on the stack
+ (fig-forth-auto680):01624 * as a single unsigned double integer,
+ (fig-forth-auto680):01625 * leaving the remainder and quotient (quotient on top)
+ (fig-forth-auto680):01626 * as unsigned integers.
+ (fig-forth-auto680):01627 *
+ (fig-forth-auto680):01628 * The smaller the divisor, the more likely dropping the high word
+ (fig-forth-auto680):01629 * of the quotient loses significant bits. See M/MOD .
+ (fig-forth-auto680):01630 *
+15D6 82 (fig-forth-auto680):01631 FCB $82
+15D7 55 (fig-forth-auto680):01632 FCC 'U' ; 'U/'
+15D8 AF (fig-forth-auto680):01633 FCB $AF
+15D9 15A0 (fig-forth-auto680):01634 FDB USTAR-5
+15DB 15DD (fig-forth-auto680):01635 USLASH FDB *+NATWID
+15DD 8611 (fig-forth-auto680):01636 LDA #17 ; bit ct
+15DF 3402 (fig-forth-auto680):01637 PSHS A
+15E1 EC42 (fig-forth-auto680):01638 LDD NATWID,U ; dividend
+15E3 10A3C4 (fig-forth-auto680):01639 USLDIV CMPD ,U ; divisor
+15E6 2404 (fig-forth-auto680):01640 BHS USLSUB
+15E8 1CFE (fig-forth-auto680):01641 ANDCC #~1 ; carry clear
+15EA 2004 (fig-forth-auto680):01642 BRA USLBIT
+15EC A3C4 (fig-forth-auto680):01643 USLSUB SUBD ,U
+15EE 1A01 (fig-forth-auto680):01644 ORCC #1 ; quotient, (carry set)
+15F0 6945 (fig-forth-auto680):01645 USLBIT ROL 2*NATWID+1,U ; save it
+15F2 6944 (fig-forth-auto680):01646 ROL 2*NATWID,U
+15F4 6AE4 (fig-forth-auto680):01647 DEC ,S ; more bits?
+15F6 2706 (fig-forth-auto680):01648 BEQ USLR
+15F8 59 (fig-forth-auto680):01649 ROLB ; remainder
+15F9 49 (fig-forth-auto680):01650 ROLA
+15FA 24E7 (fig-forth-auto680):01651 BCC USLDIV
+15FC 20EE (fig-forth-auto680):01652 BRA USLSUB
+15FE 3342 (fig-forth-auto680):01653 USLR LEAU NATWID,U
+1600 AE42 (fig-forth-auto680):01654 LDX NATWID,U
+1602 ED42 (fig-forth-auto680):01655 STD NATWID,U
+1604 AFC4 (fig-forth-auto680):01656 STX ,U
+1606 3582 (fig-forth-auto680):01657 PULS A,PC ; Avoiding a LEAS 1,S by discarding A.
+ (fig-forth-auto680):01658 *
+ (fig-forth-auto680):01659 * from 6800 model:
+ (fig-forth-auto680):01660 * LDA #17
+ (fig-forth-auto680):01661 * PSHS A ;
+ (fig-forth-auto680):01662 * TFR S,X ; TSX :
+ (fig-forth-auto680):01663 * LDA 3,X
+ (fig-forth-auto680):01664 * LDB 4,X
+ (fig-forth-auto680):01665 * USL1 CMPA 1,X
+ (fig-forth-auto680):01666 * BHI USL3
+ (fig-forth-auto680):01667 * BCS USL2
+ (fig-forth-auto680):01668 * CMPB 2,X
+ (fig-forth-auto680):01669 * BCC USL3
+ (fig-forth-auto680):01670 * USL2 ANDCC #~$01 ; CLC :
+ (fig-forth-auto680):01671 * BRA USL4
+ (fig-forth-auto680):01672 * USL3 SUBB 2,X
+ (fig-forth-auto680):01673 * SBCA 1,X
+ (fig-forth-auto680):01674 * ORCC #$01 ; SEC :
+ (fig-forth-auto680):01675 * USL4 ROL 6,X
+ (fig-forth-auto680):01676 * ROL 5,X
+ (fig-forth-auto680):01677 * DEC 0,X
+ (fig-forth-auto680):01678 * BEQ USL5
+ (fig-forth-auto680):01679 * ROLB ;
+ (fig-forth-auto680):01680 * ROLA ;
+ (fig-forth-auto680):01681 * BCC USL1
+ (fig-forth-auto680):01682 * BRA USL3
+ (fig-forth-auto680):01683 * USL5 LEAS 1,S ;
+ (fig-forth-auto680):01684 * LEAS 1,S ;
+ (fig-forth-auto680):01685 * LEAS 1,S ;
+ (fig-forth-auto680):01686 * LEAS 1,S ;
+ (fig-forth-auto680):01687 * LEAS 1,S ;
+ (fig-forth-auto680):01688 * JMP SWAP+4 reverse quotient & remainder
+ (fig-forth-auto680):01689 *
+ (fig-forth-auto680):01690 * ######>> screen 25 <<
+ (fig-forth-auto680):01691 * ======>> 20 <<
+ (fig-forth-auto680):01692 * ( n1 n2 --- n )
+ (fig-forth-auto680):01693 * Bitwise and the top two integers.
+1608 83 (fig-forth-auto680):01694 FCB $83
+1609 414E (fig-forth-auto680):01695 FCC 'AN' ; 'AND'
+160B C4 (fig-forth-auto680):01696 FCB $C4
+160C 15D6 (fig-forth-auto680):01697 FDB USLASH-5
+160E 1610 (fig-forth-auto680):01698 AND FDB *+NATWID
+1610 3706 (fig-forth-auto680):01699 PULU A,B
+1612 E441 (fig-forth-auto680):01700 ANDB 1,U
+1614 A4C4 (fig-forth-auto680):01701 ANDA ,U
+1616 EDC4 (fig-forth-auto680):01702 STD ,U
+1618 39 (fig-forth-auto680):01703 RTS
+ (fig-forth-auto680):01704 * PULS A ;
+ (fig-forth-auto680):01705 * PULS B ;
+ (fig-forth-auto680):01706 * TFR S,X ; TSX :
+ (fig-forth-auto680):01707 * ANDB 1,X
+ (fig-forth-auto680):01708 * ANDA 0,X
+ (fig-forth-auto680):01709 * JMP STABX
+ (fig-forth-auto680):01710 *
+ (fig-forth-auto680):01711 * ======>> 21 <<
+ (fig-forth-auto680):01712 * ( n1 n2 --- n )
+ (fig-forth-auto680):01713 * Bitwise or the top two integers.
+1619 82 (fig-forth-auto680):01714 FCB $82
+161A 4F (fig-forth-auto680):01715 FCC 'O' ; 'OR'
+161B D2 (fig-forth-auto680):01716 FCB $D2
+161C 1608 (fig-forth-auto680):01717 FDB AND-6
+161E 1620 (fig-forth-auto680):01718 OR FDB *+NATWID
+1620 3706 (fig-forth-auto680):01719 PULU A,B
+1622 EA41 (fig-forth-auto680):01720 ORB 1,U
+1624 AAC4 (fig-forth-auto680):01721 ORA ,U
+1626 EDC4 (fig-forth-auto680):01722 STD ,U
+1628 39 (fig-forth-auto680):01723 RTS
+ (fig-forth-auto680):01724 * PULS A ;
+ (fig-forth-auto680):01725 * PULS B ;
+ (fig-forth-auto680):01726 * TFR S,X ; TSX :
+ (fig-forth-auto680):01727 * ORB 1,X
+ (fig-forth-auto680):01728 * ORA 0,X
+ (fig-forth-auto680):01729 * JMP STABX
+ (fig-forth-auto680):01730 *
+ (fig-forth-auto680):01731 * ======>> 22 <<
+ (fig-forth-auto680):01732 * ( n1 n2 --- n )
+ (fig-forth-auto680):01733 * Bitwise exclusive or the top two integers.
+1629 83 (fig-forth-auto680):01734 FCB $83
+162A 584F (fig-forth-auto680):01735 FCC 'XO' ; 'XOR'
+162C D2 (fig-forth-auto680):01736 FCB $D2
+162D 1619 (fig-forth-auto680):01737 FDB OR-5
+162F 1631 (fig-forth-auto680):01738 XOR FDB *+NATWID
+1631 3706 (fig-forth-auto680):01739 PULU A,B
+1633 E841 (fig-forth-auto680):01740 EORB 1,U
+1635 A8C4 (fig-forth-auto680):01741 EORA ,U
+1637 EDC4 (fig-forth-auto680):01742 STD ,U
+1639 39 (fig-forth-auto680):01743 RTS
+ (fig-forth-auto680):01744 * PULS A ;
+ (fig-forth-auto680):01745 * PULS B ;
+ (fig-forth-auto680):01746 * TFR S,X ; TSX :
+ (fig-forth-auto680):01747 * EORB 1,X
+ (fig-forth-auto680):01748 * EORA 0,X
+ (fig-forth-auto680):01749 * JMP STABX
+ (fig-forth-auto680):01750 *
+ (fig-forth-auto680):01751 * ######>> screen 26 <<
+ (fig-forth-auto680):01752 * ======>> 23 <<
+ (fig-forth-auto680):01753 * ( --- adr )
+ (fig-forth-auto680):01754 * Fetch the parameter stack pointer (before it is pushed).
+ (fig-forth-auto680):01755 * This points at whatever was on the top of stack before.
+163A 83 (fig-forth-auto680):01756 FCB $83
+163B 5350 (fig-forth-auto680):01757 FCC 'SP' ; 'SP@'
+163D C0 (fig-forth-auto680):01758 FCB $C0
+163E 1629 (fig-forth-auto680):01759 FDB XOR-6
+1640 1642 (fig-forth-auto680):01760 SPAT FDB *+NATWID
+1642 1F31 (fig-forth-auto680):01761 TFR U,X
+1644 3610 (fig-forth-auto680):01762 PSHU X
+1646 39 (fig-forth-auto680):01763 RTS
+ (fig-forth-auto680):01764 * TFR S,X ; TSX :
+ (fig-forth-auto680):01765 * STX N scratch area
+ (fig-forth-auto680):01766 * LDX #N
+ (fig-forth-auto680):01767 * JMP GETX
+ (fig-forth-auto680):01768 *
+ (fig-forth-auto680):01769 * ======>> 24 <<
+ (fig-forth-auto680):01770 * ( whatever --- nothing )
+ (fig-forth-auto680):01771 * Initialize the parameter stack pointer from the USER variable S0.
+ (fig-forth-auto680):01772 * Effectively clears the stack.
+1647 83 (fig-forth-auto680):01773 FCB $83
+1648 5350 (fig-forth-auto680):01774 FCC 'SP' ; 'SP!'
+164A A1 (fig-forth-auto680):01775 FCB $A1
+164B 163A (fig-forth-auto680):01776 FDB SPAT-6
+164D 164F (fig-forth-auto680):01777 SPSTOR FDB *+NATWID
+164F DE1E (fig-forth-auto680):01778 LDU <XSPZER
+1651 39 (fig-forth-auto680):01779 RTS
+ (fig-forth-auto680):01780 * LDX UP
+ (fig-forth-auto680):01781 * LDX XSPZER-UORIG,X
+ (fig-forth-auto680):01782 * TFR X,S ; TXS : watch it ! X and S are not equal on 6800.
+ (fig-forth-auto680):01783 * JMP NEXT
+ (fig-forth-auto680):01784 * ======>> 25 <<
+ (fig-forth-auto680):01785 * ( whatever *** nothing )
+ (fig-forth-auto680):01786 * Initialize the return stack pointer from the initialization table
+ (fig-forth-auto680):01787 * instead of the user variable R0, for some reason.
+ (fig-forth-auto680):01788 * Quite possibly, this should be from R0.
+ (fig-forth-auto680):01789 * Effectively aborts all in process definitions, except the active one.
+ (fig-forth-auto680):01790 * An emergency measure, to be sure.
+ (fig-forth-auto680):01791 * The routine that calls this must never execute a return.
+ (fig-forth-auto680):01792 * So this should never be executed from the terminal, I guess.
+ (fig-forth-auto680):01793 * This is another that should be compile-time only, and in a separate vocabulary.
+1652 83 (fig-forth-auto680):01794 FCB $83
+1653 5250 (fig-forth-auto680):01795 FCC 'RP' ; 'RP!'
+1655 A1 (fig-forth-auto680):01796 FCB $A1
+1656 1647 (fig-forth-auto680):01797 FDB SPSTOR-6
+1658 165A (fig-forth-auto680):01798 RPSTOR FDB *+NATWID
+165A 3510 (fig-forth-auto680):01799 PULS X ; But this guy has to return to his caller.
+165C 10FE1214 (fig-forth-auto680):01800 LDS RINIT
+1660 6E84 (fig-forth-auto680):01801 JMP ,X
+ (fig-forth-auto680):01802 * LDX RINIT initialize from rom constant
+ (fig-forth-auto680):01803 * STX RP
+ (fig-forth-auto680):01804 * JMP NEXT
+ (fig-forth-auto680):01805 *
+ (fig-forth-auto680):01806 * ======>> 26 <<
+ (fig-forth-auto680):01807 * ( ip *** )
+ (fig-forth-auto680):01808 * Pop IP from return stack (return from high-level definition).
+ (fig-forth-auto680):01809 * Can be used in a screen to force interpretion to terminate.
+ (fig-forth-auto680):01810 * Must not be executed when temporaries are saved on top of the return stack.
+1662 82 (fig-forth-auto680):01811 FCB $82
+1663 3B (fig-forth-auto680):01812 FCC ';' ; ';S'
+1664 D3 (fig-forth-auto680):01813 FCB $D3
+1665 1652 (fig-forth-auto680):01814 FDB RPSTOR-6
+1667 1669 (fig-forth-auto680):01815 SEMIS FDB *+NATWID
+1669 3526 (fig-forth-auto680):01816 PULS D,Y ; return address in D, and saved IP in Y.
+166B 1F05 (fig-forth-auto680):01817 TFR D,PC ; Synthetic return.
+ (fig-forth-auto680):01818 *
+ (fig-forth-auto680):01819 * Form 6800 model:
+ (fig-forth-auto680):01820 * LDX RP
+ (fig-forth-auto680):01821 * LEAX 1,X ;
+ (fig-forth-auto680):01822 * LEAX 1,X ;
+ (fig-forth-auto680):01823 * STX RP
+ (fig-forth-auto680):01824 * LDX 0,X get address we have just finished.
+ (fig-forth-auto680):01825 * JMP NEXT+2 increment the return address & do next word
+ (fig-forth-auto680):01826 *
+ (fig-forth-auto680):01827 * ######>> screen 27 <<
+ (fig-forth-auto680):01828 * ======>> 27 <<
+ (fig-forth-auto680):01829 * ( limit index *** index index )
+ (fig-forth-auto680):01830 * Force the terminating condition for the innermost loop by
+ (fig-forth-auto680):01831 * copying its index to its limit.
+ (fig-forth-auto680):01832 * Termination is postponed until the next
+ (fig-forth-auto680):01833 * LOOP or +LOOP instruction is executed.
+ (fig-forth-auto680):01834 * The index remains available for use until
+ (fig-forth-auto680):01835 * the LOOP or +LOOP instruction is encountered.
+ (fig-forth-auto680):01836 * Note that the assumption is that the current count is the correct count
+ (fig-forth-auto680):01837 * to end at, rather than pushing the count to the final count.
+166D 85 (fig-forth-auto680):01838 FCB $85
+166E 4C454156 (fig-forth-auto680):01839 FCC 'LEAV' ; 'LEAVE'
+1672 C5 (fig-forth-auto680):01840 FCB $C5
+1673 1662 (fig-forth-auto680):01841 FDB SEMIS-5
+1675 1677 (fig-forth-auto680):01842 LEAVE FDB *+NATWID
+1677 EC62 (fig-forth-auto680):01843 LDD NATWID,S ; Dodge the return address.
+1679 ED64 (fig-forth-auto680):01844 STD 2*NATWID,S
+167B 39 (fig-forth-auto680):01845 RTS
+ (fig-forth-auto680):01846 * LDX RP
+ (fig-forth-auto680):01847 * LDA 2,X
+ (fig-forth-auto680):01848 * LDB 3,X
+ (fig-forth-auto680):01849 * STA 4,X
+ (fig-forth-auto680):01850 * STB 5,X
+ (fig-forth-auto680):01851 * JMP NEXT
+ (fig-forth-auto680):01852 *
+ (fig-forth-auto680):01853 * ======>> 28 <<
+ (fig-forth-auto680):01854 * ( n --- )
+ (fig-forth-auto680):01855 * ( *** n )
+ (fig-forth-auto680):01856 * Move top of parameter stack to top of return stack.
+167C 82 (fig-forth-auto680):01857 FCB $82
+167D 3E (fig-forth-auto680):01858 FCC '>' ; '>R'
+167E D2 (fig-forth-auto680):01859 FCB $D2
+167F 166D (fig-forth-auto680):01860 FDB LEAVE-8
+1681 1683 (fig-forth-auto680):01861 TOR FDB *+NATWID
+1683 3706 (fig-forth-auto680):01862 PULU A,B
+1685 AEE4 (fig-forth-auto680):01863 LDX ,S
+1687 EDE4 (fig-forth-auto680):01864 STD ,S ; Put it where the return address was.
+1689 6E84 (fig-forth-auto680):01865 JMP ,X
+ (fig-forth-auto680):01866 * LDX RP
+ (fig-forth-auto680):01867 * LEAX -1,X ;
+ (fig-forth-auto680):01868 * LEAX -1,X ;
+ (fig-forth-auto680):01869 * STX RP
+ (fig-forth-auto680):01870 * PULS A ;
+ (fig-forth-auto680):01871 * PULS B ;
+ (fig-forth-auto680):01872 * STA 2,X
+ (fig-forth-auto680):01873 * STB 3,X
+ (fig-forth-auto680):01874 * JMP NEXT
+ (fig-forth-auto680):01875 *
+ (fig-forth-auto680):01876 * ======>> 29 <<
+ (fig-forth-auto680):01877 * ( --- n )
+ (fig-forth-auto680):01878 * ( n *** )
+ (fig-forth-auto680):01879 * Move top of return stack to top of parameter stack.
+168B 82 (fig-forth-auto680):01880 FCB $82
+168C 52 (fig-forth-auto680):01881 FCC 'R' ; 'R>'
+168D BE (fig-forth-auto680):01882 FCB $BE
+168E 167C (fig-forth-auto680):01883 FDB TOR-5
+1690 1692 (fig-forth-auto680):01884 FROMR FDB *+NATWID
+1692 3516 (fig-forth-auto680):01885 PULS D,X
+1694 3610 (fig-forth-auto680):01886 PSHU X
+1696 1F05 (fig-forth-auto680):01887 TFR D,PC
+ (fig-forth-auto680):01888 * LDX RP
+ (fig-forth-auto680):01889 * LDA 2,X
+ (fig-forth-auto680):01890 * LDB 3,X
+ (fig-forth-auto680):01891 * LEAX 1,X ;
+ (fig-forth-auto680):01892 * LEAX 1,X ;
+ (fig-forth-auto680):01893 * STX RP
+ (fig-forth-auto680):01894 * JMP PUSHBA
+ (fig-forth-auto680):01895 *
+ (fig-forth-auto680):01896 * ======>> 30 <<
+ (fig-forth-auto680):01897 * ( --- n )
+ (fig-forth-auto680):01898 * ( n *** n )
+ (fig-forth-auto680):01899 * Copy the top of return stack to top of parameter stack.
+ (fig-forth-auto680):01900 * A synonym for I.
+1698 81 (fig-forth-auto680):01901 FCB $81 R
+1699 D2 (fig-forth-auto680):01902 FCB $D2
+169A 168B (fig-forth-auto680):01903 FDB FROMR-5
+169C 1467 (fig-forth-auto680):01904 R FDB I+NATWID
+ (fig-forth-auto680):01905
+ (fig-forth-auto680):01906 * LDX RP
+ (fig-forth-auto680):01907 * LEAX 1,X ;
+ (fig-forth-auto680):01908 * LEAX 1,X ;
+ (fig-forth-auto680):01909 * JMP GETX
+ (fig-forth-auto680):01910 *
+ (fig-forth-auto680):01911 * ######>> screen 28 <<
+ (fig-forth-auto680):01912 * ======>> 31 <<
+ (fig-forth-auto680):01913 * ( n --- n=0 )
+ (fig-forth-auto680):01914 * Logically invert top of stack;
+ (fig-forth-auto680):01915 * or flag true if top is zero, otherwise false.
+169E 82 (fig-forth-auto680):01916 FCB $82
+169F 30 (fig-forth-auto680):01917 FCC '0' ; '0='
+16A0 BD (fig-forth-auto680):01918 FCB $BD
+16A1 1698 (fig-forth-auto680):01919 FDB R-4
+16A3 16A5 (fig-forth-auto680):01920 ZEQU FDB *+NATWID
+16A5 CC0000 (fig-forth-auto680):01921 LDD #0
+16A8 AEC4 (fig-forth-auto680):01922 LDX ,U
+16AA 2601 (fig-forth-auto680):01923 BNE ZEQUF
+16AC 5C (fig-forth-auto680):01924 INCB ; 1 is true
+16AD EDC4 (fig-forth-auto680):01925 ZEQUF STD ,U
+16AF 39 (fig-forth-auto680):01926 RTS
+ (fig-forth-auto680):01927 * TFR S,X ; TSX :
+ (fig-forth-auto680):01928 * CLRA ;
+ (fig-forth-auto680):01929 * CLRB ;
+ (fig-forth-auto680):01930 * LDX 0,X
+ (fig-forth-auto680):01931 * BNE ZEQU2
+ (fig-forth-auto680):01932 * INCB ;
+ (fig-forth-auto680):01933 *ZEQU2 TFR S,X ; TSX :
+ (fig-forth-auto680):01934 * JMP STABX
+ (fig-forth-auto680):01935 *
+ (fig-forth-auto680):01936 * ======>> 32 <<
+ (fig-forth-auto680):01937 * ( n --- n<0 )
+ (fig-forth-auto680):01938 * Flag true if top is negative (MSbit set), otherwise false.
+16B0 82 (fig-forth-auto680):01939 FCB $82
+16B1 30 (fig-forth-auto680):01940 FCC '0' ; '0<'
+16B2 BC (fig-forth-auto680):01941 FCB $BC
+16B3 169E (fig-forth-auto680):01942 FDB ZEQU-5
+16B5 16B7 (fig-forth-auto680):01943 ZLESS FDB *+NATWID
+16B7 CC0000 (fig-forth-auto680):01944 LDD #0
+16BA 6DC4 (fig-forth-auto680):01945 TST ,U
+16BC 2A01 (fig-forth-auto680):01946 BPL ZLESSF
+16BE 5C (fig-forth-auto680):01947 INCB
+16BF EDC4 (fig-forth-auto680):01948 ZLESSF STD ,U
+16C1 39 (fig-forth-auto680):01949 RTS
+ (fig-forth-auto680):01950 * TFR S,X ; TSX :
+ (fig-forth-auto680):01951 * LDA #$80 check the sign bit
+ (fig-forth-auto680):01952 * ANDA 0,X
+ (fig-forth-auto680):01953 * BEQ ZLESS2
+ (fig-forth-auto680):01954 * CLRA ; if neg.
+ (fig-forth-auto680):01955 * LDB #1
+ (fig-forth-auto680):01956 * JMP STABX
+ (fig-forth-auto680):01957 * ZLESS2 CLRB ;
+ (fig-forth-auto680):01958 * JMP STABX
+ (fig-forth-auto680):01959 *
+ (fig-forth-auto680):01960 * ######>> screen 29 <<
+ (fig-forth-auto680):01961 * ======>> 33 <<
+ (fig-forth-auto680):01962 * ( n1 n2 --- n1+n2 )
+ (fig-forth-auto680):01963 * Add top two words.
+16C2 81 (fig-forth-auto680):01964 FCB $81 '+'
+16C3 AB (fig-forth-auto680):01965 FCB $AB
+16C4 16B0 (fig-forth-auto680):01966 FDB ZLESS-5
+16C6 16C8 (fig-forth-auto680):01967 PLUS FDB *+NATWID
+16C8 3706 (fig-forth-auto680):01968 PULU A,B ; #2~7
+16CA E3C4 (fig-forth-auto680):01969 ADDD ,U ; #2~6
+16CC EDC4 (fig-forth-auto680):01970 STD ,U ; #2~5
+16CE 39 (fig-forth-auto680):01971 RTS ; #1~5 =#7~23
+ (fig-forth-auto680):01972 * PULS A ;
+ (fig-forth-auto680):01973 * PULS B ;
+ (fig-forth-auto680):01974 * TFR S,X ; TSX :
+ (fig-forth-auto680):01975 * ADDB 1,X
+ (fig-forth-auto680):01976 * ADCA 0,X
+ (fig-forth-auto680):01977 * JMP STABX
+ (fig-forth-auto680):01978 *
+ (fig-forth-auto680):01979 * ======>> 34 <<
+ (fig-forth-auto680):01980 * ( d1 d2 --- d1+d2 )
+ (fig-forth-auto680):01981 * Add top two double integers.
+16CF 82 (fig-forth-auto680):01982 FCB $82
+16D0 44 (fig-forth-auto680):01983 FCC 'D' ; 'D+'
+16D1 AB (fig-forth-auto680):01984 FCB $AB
+16D2 16C2 (fig-forth-auto680):01985 FDB PLUS-4
+16D4 16D6 (fig-forth-auto680):01986 DPLUS FDB *+NATWID
+16D6 EC46 (fig-forth-auto680):01987 LDD 3*NATWID,U
+16D8 E342 (fig-forth-auto680):01988 ADDD NATWID,U
+16DA ED46 (fig-forth-auto680):01989 STD 3*NATWID,U
+16DC EC44 (fig-forth-auto680):01990 LDD 2*NATWID,U
+16DE E941 (fig-forth-auto680):01991 ADCB 1,U
+16E0 A9C4 (fig-forth-auto680):01992 ADCA ,U
+16E2 3344 (fig-forth-auto680):01993 LEAU 2*NATWID,U
+16E4 EDC4 (fig-forth-auto680):01994 STD ,U
+16E6 39 (fig-forth-auto680):01995 RTS
+ (fig-forth-auto680):01996 * TFR S,X ; TSX :
+ (fig-forth-auto680):01997 * ANDCC #~$01 ; CLC :
+ (fig-forth-auto680):01998 * LDB #4
+ (fig-forth-auto680):01999 * DPLUS2 LDA 3,X
+ (fig-forth-auto680):02000 * ADCA 7,X
+ (fig-forth-auto680):02001 * STA 7,X
+ (fig-forth-auto680):02002 * LEAX -1,X ;
+ (fig-forth-auto680):02003 * DECB ;
+ (fig-forth-auto680):02004 * BNE DPLUS2
+ (fig-forth-auto680):02005 * LEAS 1,S ;
+ (fig-forth-auto680):02006 * LEAS 1,S ;
+ (fig-forth-auto680):02007 * LEAS 1,S ;
+ (fig-forth-auto680):02008 * LEAS 1,S ;
+ (fig-forth-auto680):02009 * JMP NEXT
+ (fig-forth-auto680):02010 *
+ (fig-forth-auto680):02011 * ======>> 35 <<
+ (fig-forth-auto680):02012 * ( n --- -n )
+ (fig-forth-auto680):02013 * Negate (two's complement) top of stack.
+16E7 85 (fig-forth-auto680):02014 FCB $85
+16E8 4D494E55 (fig-forth-auto680):02015 FCC 'MINU' ; 'MINUS'
+16EC D3 (fig-forth-auto680):02016 FCB $D3
+16ED 16CF (fig-forth-auto680):02017 FDB DPLUS-5
+16EF 16F1 (fig-forth-auto680):02018 MINUS FDB *+NATWID
+16F1 CC0000 (fig-forth-auto680):02019 LDD #0 ; #3~3
+16F4 A3C4 (fig-forth-auto680):02020 SUBD ,U ; #2~5
+16F6 EDC4 (fig-forth-auto680):02021 STD ,U ; #2~5
+16F8 39 (fig-forth-auto680):02022 RTS ; #1~5 = #8~18
+ (fig-forth-auto680):02023 *
+ (fig-forth-auto680):02024 * from 6800 model code:
+ (fig-forth-auto680):02025 * TFR S,X ; TSX :
+ (fig-forth-auto680):02026 * NEG 1,X
+ (fig-forth-auto680):02027 * BCC MINUS2
+ (fig-forth-auto680):02028 * NEG 0,X
+ (fig-forth-auto680):02029 * BRA MINUS3
+ (fig-forth-auto680):02030 * MINUS2 COM 0,X
+ (fig-forth-auto680):02031 * MINUS3 JMP NEXT
+ (fig-forth-auto680):02032 *
+ (fig-forth-auto680):02033 * ======>> 36 <<
+ (fig-forth-auto680):02034 * ( d --- -d )
+ (fig-forth-auto680):02035 * Negate (two's complement) top two words on stack as a double integer.
+16F9 86 (fig-forth-auto680):02036 FCB $86
+16FA 444D494E55 (fig-forth-auto680):02037 FCC 'DMINU' ; 'DMINUS'
+16FF D3 (fig-forth-auto680):02038 FCB $D3
+1700 16E7 (fig-forth-auto680):02039 FDB MINUS-8
+1702 1704 (fig-forth-auto680):02040 DMINUS FDB *+NATWID
+1704 CC0000 (fig-forth-auto680):02041 LDD #0 ; #3~3
+1707 A342 (fig-forth-auto680):02042 SUBD NATWID,U ; #2~7
+1709 ED42 (fig-forth-auto680):02043 STD NATWID,U ; #2~7
+170B CC0000 (fig-forth-auto680):02044 LDD #0 ; #3~3
+170E E241 (fig-forth-auto680):02045 SBCB 1,U ; #2~5
+1710 A2C4 (fig-forth-auto680):02046 SBCA ,U ; #2~4
+1712 EDC4 (fig-forth-auto680):02047 STD ,U ; #2~5
+1714 39 (fig-forth-auto680):02048 RTS ; #1~5 = #17~39
+ (fig-forth-auto680):02049 * TFR S,X ; TSX :
+ (fig-forth-auto680):02050 * COM 0,X
+ (fig-forth-auto680):02051 * COM 1,X
+ (fig-forth-auto680):02052 * COM 2,X
+ (fig-forth-auto680):02053 * NEG 3,X
+ (fig-forth-auto680):02054 * BNE DMINX
+ (fig-forth-auto680):02055 * INC 2,X
+ (fig-forth-auto680):02056 * BNE DMINX
+ (fig-forth-auto680):02057 * INC 1,X
+ (fig-forth-auto680):02058 * BNE DMINX
+ (fig-forth-auto680):02059 * INC 0,X
+ (fig-forth-auto680):02060 * DMINX JMP NEXT
+ (fig-forth-auto680):02061 *
+ (fig-forth-auto680):02062 * ######>> screen 30 <<
+ (fig-forth-auto680):02063 * ======>> 37 <<
+ (fig-forth-auto680):02064 * ( n1 n2 --- n1 n2 n1 )
+ (fig-forth-auto680):02065 * Push a copy of the second word on stack.
+1715 84 (fig-forth-auto680):02066 FCB $84
+1716 4F5645 (fig-forth-auto680):02067 FCC 'OVE' ; 'OVER'
+1719 D2 (fig-forth-auto680):02068 FCB $D2
+171A 16F9 (fig-forth-auto680):02069 FDB DMINUS-9
+171C 171E (fig-forth-auto680):02070 OVER FDB *+NATWID
+171E EC42 (fig-forth-auto680):02071 LDD NATWID,U
+1720 3606 (fig-forth-auto680):02072 PSHU D
+1722 39 (fig-forth-auto680):02073 RTS
+ (fig-forth-auto680):02074 * TFR S,X ; TSX :
+ (fig-forth-auto680):02075 * LDA 2,X
+ (fig-forth-auto680):02076 * LDB 3,X
+ (fig-forth-auto680):02077 * JMP PUSHBA
+ (fig-forth-auto680):02078 *
+ (fig-forth-auto680):02079 * ======>> 38 <<
+ (fig-forth-auto680):02080 * ( n --- )
+ (fig-forth-auto680):02081 * Discard the top word on stack.
+1723 84 (fig-forth-auto680):02082 FCB $84
+1724 44524F (fig-forth-auto680):02083 FCC 'DRO' ; 'DROP'
+1727 D0 (fig-forth-auto680):02084 FCB $D0
+1728 1715 (fig-forth-auto680):02085 FDB OVER-7
+172A 172C (fig-forth-auto680):02086 DROP FDB *+NATWID
+172C 3342 (fig-forth-auto680):02087 LEAU NATWID,U
+172E 39 (fig-forth-auto680):02088 RTS
+ (fig-forth-auto680):02089 * LEAS 1,S ;
+ (fig-forth-auto680):02090 * LEAS 1,S ;
+ (fig-forth-auto680):02091 * JMP NEXT
+ (fig-forth-auto680):02092 *
+ (fig-forth-auto680):02093 * ======>> 39 <<
+ (fig-forth-auto680):02094 * ( n1 n2 --- n2 n1 )
+ (fig-forth-auto680):02095 * Swap the top two words on stack.
+172F 84 (fig-forth-auto680):02096 FCB $84
+1730 535741 (fig-forth-auto680):02097 FCC 'SWA' ; 'SWAP'
+1733 D0 (fig-forth-auto680):02098 FCB $D0
+1734 1723 (fig-forth-auto680):02099 FDB DROP-7
+1736 1738 (fig-forth-auto680):02100 SWAP FDB *+NATWID
+1738 3716 (fig-forth-auto680):02101 PULU D,X
+173A 3606 (fig-forth-auto680):02102 PSHU D
+173C 3610 (fig-forth-auto680):02103 PSHU X
+173E 39 (fig-forth-auto680):02104 RTS
+ (fig-forth-auto680):02105 * PULS A ;
+ (fig-forth-auto680):02106 * PULS B ;
+ (fig-forth-auto680):02107 * TFR S,X ; TSX :
+ (fig-forth-auto680):02108 * LDX 0,X
+ (fig-forth-auto680):02109 * LEAS 1,S ;
+ (fig-forth-auto680):02110 * LEAS 1,S ;
+ (fig-forth-auto680):02111 * PSHS B ;
+ (fig-forth-auto680):02112 * PSHS A ;
+ (fig-forth-auto680):02113 * STX N
+ (fig-forth-auto680):02114 * LDX #N
+ (fig-forth-auto680):02115 * JMP GETX
+ (fig-forth-auto680):02116 *
+ (fig-forth-auto680):02117 * ======>> 40 <<
+ (fig-forth-auto680):02118 * ( n1 --- n1 n1 )
+ (fig-forth-auto680):02119 * Push a copy of the top word on stack.
+173F 83 (fig-forth-auto680):02120 FCB $83
+1740 4455 (fig-forth-auto680):02121 FCC 'DU' ; 'DUP'
+1742 D0 (fig-forth-auto680):02122 FCB $D0
+1743 172F (fig-forth-auto680):02123 FDB SWAP-7
+1745 1747 (fig-forth-auto680):02124 DUP FDB *+NATWID
+1747 ECC4 (fig-forth-auto680):02125 LDD ,U
+1749 3606 (fig-forth-auto680):02126 PSHU D
+174B 39 (fig-forth-auto680):02127 RTS
+ (fig-forth-auto680):02128 * PULS A ;
+ (fig-forth-auto680):02129 * PULS B ;
+ (fig-forth-auto680):02130 * PSHS B ;
+ (fig-forth-auto680):02131 * PSHS A ;
+ (fig-forth-auto680):02132 * JMP PUSHBA
+ (fig-forth-auto680):02133 *
+ (fig-forth-auto680):02134 * ######>> screen 31 <<
+ (fig-forth-auto680):02135 * ======>> 41 <<
+ (fig-forth-auto680):02136 * ( n adr --- )
+ (fig-forth-auto680):02137 * Add the second word on stack to the word at the adr on top of stack.
+174C 82 (fig-forth-auto680):02138 FCB $82
+174D 2B (fig-forth-auto680):02139 FCC '+' ; '+!'
+174E A1 (fig-forth-auto680):02140 FCB $A1
+174F 173F (fig-forth-auto680):02141 FDB DUP-6
+1751 1753 (fig-forth-auto680):02142 PSTORE FDB *+NATWID
+1753 3710 (fig-forth-auto680):02143 PULU X
+1755 EC84 (fig-forth-auto680):02144 LDD ,X
+1757 E3C1 (fig-forth-auto680):02145 ADDD ,U++
+1759 ED84 (fig-forth-auto680):02146 STD ,X
+175B 39 (fig-forth-auto680):02147 RTS
+ (fig-forth-auto680):02148 * TFR S,X ; TSX :
+ (fig-forth-auto680):02149 * LDX 0,X
+ (fig-forth-auto680):02150 * LEAS 1,S ;
+ (fig-forth-auto680):02151 * LEAS 1,S ;
+ (fig-forth-auto680):02152 * PULS A ; get stack data
+ (fig-forth-auto680):02153 * PULS B ;
+ (fig-forth-auto680):02154 * ADDB 1,X add & store low byte
+ (fig-forth-auto680):02155 * STB 1,X
+ (fig-forth-auto680):02156 * ADCA 0,X add & store hi byte
+ (fig-forth-auto680):02157 * STA 0,X
+ (fig-forth-auto680):02158 * JMP NEXT
+ (fig-forth-auto680):02159 *
+ (fig-forth-auto680):02160 * ======>> 42 <<
+ (fig-forth-auto680):02161 * ( adr b --- )
+ (fig-forth-auto680):02162 * Exclusive or byte at adr with low byte of top word.
+175C 86 (fig-forth-auto680):02163 FCB $86
+175D 544F47474C (fig-forth-auto680):02164 FCC 'TOGGL' ; 'TOGGLE'
+1762 C5 (fig-forth-auto680):02165 FCB $C5
+1763 174C (fig-forth-auto680):02166 FDB PSTORE-5
+1765 1767 (fig-forth-auto680):02167 TOGGLE FDB *+NATWID
+1767 3716 (fig-forth-auto680):02168 PULU D,X
+1769 E884 (fig-forth-auto680):02169 EORB ,X
+176B E784 (fig-forth-auto680):02170 STB ,X
+176D 39 (fig-forth-auto680):02171 RTS
+ (fig-forth-auto680):02172 * Using the model code would be less likely to introduce bugs,
+ (fig-forth-auto680):02173 * but that would sort-of defeat my purposes here.
+ (fig-forth-auto680):02174 * Anyway, I can borrow from theoretically known good bif-6809 code
+ (fig-forth-auto680):02175 * and it's fewer bytes and much faster code this way.
+ (fig-forth-auto680):02176 * TOGGLE
+ (fig-forth-auto680):02177 * FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
+ (fig-forth-auto680):02178 * FDB SEMIS
+ (fig-forth-auto680):02179 *
+ (fig-forth-auto680):02180 * ######>> screen 32 <<
+ (fig-forth-auto680):02181 * ======>> 43 <<
+ (fig-forth-auto680):02182 * ( adr --- n )
+ (fig-forth-auto680):02183 * Replace address on stack with the word at the address.
+176E 81 (fig-forth-auto680):02184 FCB $81 @
+176F C0 (fig-forth-auto680):02185 FCB $C0
+1770 175C (fig-forth-auto680):02186 FDB TOGGLE-9
+1772 1774 (fig-forth-auto680):02187 AT FDB *+NATWID
+1774 ECD4 (fig-forth-auto680):02188 LDD [,U]
+1776 EDC4 (fig-forth-auto680):02189 STD ,U
+1778 39 (fig-forth-auto680):02190 RTS
+ (fig-forth-auto680):02191 * TFR S,X ; TSX :
+ (fig-forth-auto680):02192 * LDX 0,X get address
+ (fig-forth-auto680):02193 * LEAS 1,S ;
+ (fig-forth-auto680):02194 * LEAS 1,S ;
+ (fig-forth-auto680):02195 * JMP GETX
+ (fig-forth-auto680):02196 *
+ (fig-forth-auto680):02197 * ======>> 44 <<
+ (fig-forth-auto680):02198 * ( adr --- b )
+ (fig-forth-auto680):02199 * Replace address on top of stack with the byte at the address.
+ (fig-forth-auto680):02200 * High byte of result is clear.
+1779 82 (fig-forth-auto680):02201 FCB $82
+177A 43 (fig-forth-auto680):02202 FCC 'C' ; 'C@'
+177B C0 (fig-forth-auto680):02203 FCB $C0
+177C 176E (fig-forth-auto680):02204 FDB AT-4
+177E 1780 (fig-forth-auto680):02205 CAT FDB *+NATWID
+1780 E6D4 (fig-forth-auto680):02206 LDB [,U]
+1782 4F (fig-forth-auto680):02207 CLRA
+1783 EDC4 (fig-forth-auto680):02208 STD ,U
+1785 39 (fig-forth-auto680):02209 RTS
+ (fig-forth-auto680):02210
+ (fig-forth-auto680):02211
+ (fig-forth-auto680):02212 * TFR S,X ; TSX :
+ (fig-forth-auto680):02213 * LDX 0,X
+ (fig-forth-auto680):02214 * CLRA ;
+ (fig-forth-auto680):02215 * LDB 0,X
+ (fig-forth-auto680):02216 * LEAS 1,S ;
+ (fig-forth-auto680):02217 * LEAS 1,S ;
+ (fig-forth-auto680):02218 * JMP PUSHBA
+ (fig-forth-auto680):02219 *
+ (fig-forth-auto680):02220 * ======>> 45 <<
+ (fig-forth-auto680):02221 * ( n adr --- )
+ (fig-forth-auto680):02222 * Store second word on stack at address on top of stack.
+1786 81 (fig-forth-auto680):02223 FCB $81
+1787 A1 (fig-forth-auto680):02224 FCB $A1
+1788 1779 (fig-forth-auto680):02225 FDB CAT-5
+178A 178C (fig-forth-auto680):02226 STORE FDB *+NATWID
+178C EC42 (fig-forth-auto680):02227 LDD NATWID,U
+178E EDD4 (fig-forth-auto680):02228 STD [,U]
+1790 3344 (fig-forth-auto680):02229 LEAU 2*NATWID,U
+1792 39 (fig-forth-auto680):02230 RTS
+ (fig-forth-auto680):02231 * TFR S,X ; TSX :
+ (fig-forth-auto680):02232 * LDX 0,X get address
+ (fig-forth-auto680):02233 * LEAS 1,S ;
+ (fig-forth-auto680):02234 * LEAS 1,S ;
+ (fig-forth-auto680):02235 * JMP PULABX
+ (fig-forth-auto680):02236 *
+ (fig-forth-auto680):02237 * ======>> 46 <<
+ (fig-forth-auto680):02238 * ( b adr --- )
+ (fig-forth-auto680):02239 * Store low byte of second word on stack at address on top of stack.
+ (fig-forth-auto680):02240 * High byte is ignored.
+1793 82 (fig-forth-auto680):02241 FCB $82
+1794 43 (fig-forth-auto680):02242 FCC 'C' ; 'C!'
+1795 A1 (fig-forth-auto680):02243 FCB $A1
+1796 1786 (fig-forth-auto680):02244 FDB STORE-4
+1798 179A (fig-forth-auto680):02245 CSTORE FDB *+NATWID
+179A E643 (fig-forth-auto680):02246 LDB 3,U
+179C E7D4 (fig-forth-auto680):02247 STB [,U]
+179E 3344 (fig-forth-auto680):02248 LEAU 2*NATWID,U
+17A0 39 (fig-forth-auto680):02249 RTS
+ (fig-forth-auto680):02250 * TFR S,X ; TSX :
+ (fig-forth-auto680):02251 * LDX 0,X get address
+ (fig-forth-auto680):02252 * LEAS 1,S ;
+ (fig-forth-auto680):02253 * LEAS 1,S ;
+ (fig-forth-auto680):02254 * LEAS 1,S ;
+ (fig-forth-auto680):02255 * PULS B ;
+ (fig-forth-auto680):02256 * STB 0,X
+ (fig-forth-auto680):02257 * JMP NEXT
+ (fig-forth-auto680):02258 PAGE
+ (fig-forth-auto680):02259 *
+ (fig-forth-auto680):02260 * ######>> screen 33 <<
+ (fig-forth-auto680):02261 * ======>> 47 <<
+ (fig-forth-auto680):02262 * ( --- ) P
+ (fig-forth-auto680):02263 * { : name sundry-activities ; } typical input
+ (fig-forth-auto680):02264 * If executing (not compiling),
+ (fig-forth-auto680):02265 * record the data stack mark in CSP,
+ (fig-forth-auto680):02266 * Set the CONTEXT vocabulary to CURRENT,
+ (fig-forth-auto680):02267 * CREATE a header,
+ (fig-forth-auto680):02268 * set state to compile,
+ (fig-forth-auto680):02269 * and compile the call to the trailing native CPU machine code DOCOL.
+ (fig-forth-auto680):02270 *
+ (fig-forth-auto680):02271 * This would not be hard to flatten to native code.
+ (fig-forth-auto680):02272 * But that's not the purpose of a model.
+17A1 C1 (fig-forth-auto680):02273 FCB $C1 : immediate
+17A2 BA (fig-forth-auto680):02274 FCB $BA
+17A3 1793 (fig-forth-auto680):02275 FDB CSTORE-5
+17A5 17B91B6A1B26194C (fig-forth-auto680):02276 COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
+ 1772193E178A
+17B3 20661BEB (fig-forth-auto680):02277 FDB CREATE,RBRAK
+17B7 1C3A (fig-forth-auto680):02278 FDB PSCODE
+ (fig-forth-auto680):02279
+ (fig-forth-auto680):02280 * Here is the IP pusher for allowing
+ (fig-forth-auto680):02281 * nested words in the virtual machine:
+ (fig-forth-auto680):02282 * ( ;S is the equivalent un-nester )
+ (fig-forth-auto680):02283
+ (fig-forth-auto680):02284 * ( *** oldIP )
+ (fig-forth-auto680):02285 * Characteristic of a colon (:) definition.
+ (fig-forth-auto680):02286 * Begins execution of a high-level definition,
+ (fig-forth-auto680):02287 * i. e., nests the definition and begins processing icodes.
+ (fig-forth-auto680):02288 * Mechanically, it pushes the IP (Y register)
+ (fig-forth-auto680):02289 * and loads the Parameter Field Address of the definition which
+ (fig-forth-auto680):02290 * called it into the IP.
+17B9 ECE4 (fig-forth-auto680):02291 DOCOL LDD ,S ; Save the return address.
+17BB 10AFE4 (fig-forth-auto680):02292 STY ,S ; Nest the old IP.
+17BE 3102 (fig-forth-auto680):02293 LEAY NATWID,X ; W still in X, bump to parameters, load as new IP.
+17C0 1F05 (fig-forth-auto680):02294 TFR D,PC ; synthetic return to interpret.
+ (fig-forth-auto680):02295
+ (fig-forth-auto680):02296 * DOCOL LDX RP make room in the stack
+ (fig-forth-auto680):02297 * LEAX -1,X ;
+ (fig-forth-auto680):02298 * LEAX -1,X ;
+ (fig-forth-auto680):02299 * STX RP
+ (fig-forth-auto680):02300 * LDA IP
+ (fig-forth-auto680):02301 * LDB IP+1
+ (fig-forth-auto680):02302 * STA 2,X Store address of the high level word
+ (fig-forth-auto680):02303 * STB 3,X that we are starting to execute
+ (fig-forth-auto680):02304 * LDX W Get first sub-word of that definition
+ (fig-forth-auto680):02305 * JMP NEXT+2 and execute it
+ (fig-forth-auto680):02306 *
+ (fig-forth-auto680):02307 * ======>> 48 <<
+ (fig-forth-auto680):02308 * ( --- ) P
+ (fig-forth-auto680):02309 * { : name sundry-activities ; } typical input
+ (fig-forth-auto680):02310 * ERROR check data stack against mark in CSP,
+ (fig-forth-auto680):02311 * compile ;S,
+ (fig-forth-auto680):02312 * unSMUDGE LATEST definition,
+ (fig-forth-auto680):02313 * and set state to interpretation.
+17C2 C1 (fig-forth-auto680):02314 FCB $C1 ; imnediate code
+17C3 BB (fig-forth-auto680):02315 FCB $BB
+17C4 17A1 (fig-forth-auto680):02316 FDB COLON-4
+17C6 17B91B921BC71667 (fig-forth-auto680):02317 SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
+ 1BFF1BDD
+17D2 1667 (fig-forth-auto680):02318 FDB SEMIS
+ (fig-forth-auto680):02319 *
+ (fig-forth-auto680):02320 * ######>> screen 34 <<
+ (fig-forth-auto680):02321 * ======>> 49 <<
+ (fig-forth-auto680):02322 * ( n --- )
+ (fig-forth-auto680):02323 * { value CONSTANT name } typical input
+ (fig-forth-auto680):02324 * CREATE a header,
+ (fig-forth-auto680):02325 * unSMUDGE it,
+ (fig-forth-auto680):02326 * compile the constant value,
+ (fig-forth-auto680):02327 * and compile the call to the trailing native CPU machine code DOCON.
+17D4 88 (fig-forth-auto680):02328 FCB $88
+17D5 434F4E5354414E (fig-forth-auto680):02329 FCC 'CONSTAN' ; 'CONSTANT'
+17DC D4 (fig-forth-auto680):02330 FCB $D4
+17DD 17C2 (fig-forth-auto680):02331 FDB SEMI-4
+17DF 17B920661BFF19E3 (fig-forth-auto680):02332 CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
+ 1C3A
+ (fig-forth-auto680):02333 * ( --- n )
+ (fig-forth-auto680):02334 * Characteristic of a CONSTANT.
+ (fig-forth-auto680):02335 * A CONSTANT simply loads its value from its parameter field
+ (fig-forth-auto680):02336 * and pushes it on the stack.
+17E9 EC02 (fig-forth-auto680):02337 DOCON LDD NATWID,X ; Get the first natural width word of the parameter field.
+17EB 3606 (fig-forth-auto680):02338 PSHU D
+17ED 39 (fig-forth-auto680):02339 RTS
+ (fig-forth-auto680):02340 * DOCON LDX W
+ (fig-forth-auto680):02341 * LDA 2,X
+ (fig-forth-auto680):02342 * LDB 3,X A & B now contain the constant
+ (fig-forth-auto680):02343 * JMP PUSHBA
+ (fig-forth-auto680):02344 *
+ (fig-forth-auto680):02345 * Not in model, needed for abstraction:
+ (fig-forth-auto680):02346 * ( --- NATWID )
+ (fig-forth-auto680):02347 * The byte width of objects on stack.
+17EE 86 (fig-forth-auto680):02348 FCB $86
+17EF 4E41545749 (fig-forth-auto680):02349 FCC 'NATWI' ; 'NATWID'
+17F4 C4 (fig-forth-auto680):02350 FCB $C4
+17F5 17D4 (fig-forth-auto680):02351 FDB CON-11
+17F7 17E9 (fig-forth-auto680):02352 NATWC FDB DOCON
+17F9 0002 (fig-forth-auto680):02353 NATWCV FDB NATWID
+ (fig-forth-auto680):02354 *
+ (fig-forth-auto680):02355 * Not in model, needed for abstraction:
+ (fig-forth-auto680):02356 * Note that this is not defined as an INCREMENTER!
+ (fig-forth-auto680):02357 * Coded to increment by the exact constant returned by NATWID
+ (fig-forth-auto680):02358 * ( n --- n+NATWID )
+17FB 84 (fig-forth-auto680):02359 FCB $84
+17FC 4E4154 (fig-forth-auto680):02360 FCC 'NAT' ; 'NAT+'
+17FF AB (fig-forth-auto680):02361 FCB $AB
+1800 17EE (fig-forth-auto680):02362 FDB NATWC-9
+1802 1804 (fig-forth-auto680):02363 NATP FDB *+NATWID
+1804 ECC4 (fig-forth-auto680):02364 LDD ,U
+1806 E38CF0 (fig-forth-auto680):02365 ADDD NATWCV,PCR ; Looking ahead, does not have to be PCRelative.
+1809 EDC4 (fig-forth-auto680):02366 STD ,U
+180B 39 (fig-forth-auto680):02367 RTS
+ (fig-forth-auto680):02368 * How this might have been done for 6800 model:
+ (fig-forth-auto680):02369 * CLRA ; We know the natural width is less than 255, LOL.
+ (fig-forth-auto680):02370 * LDAB NATWCV+1
+ (fig-forth-auto680):02371 * TSX
+ (fig-forth-auto680):02372 * ADDB 1,X
+ (fig-forth-auto680):02373 * ADCA ,X
+ (fig-forth-auto680):02374 * JMP STABX
+ (fig-forth-auto680):02375 *
+ (fig-forth-auto680):02376 * ======>> 50 <<
+ (fig-forth-auto680):02377 * ( init --- )
+ (fig-forth-auto680):02378 * { init VARIABLE name } typical input
+ (fig-forth-auto680):02379 * Use CONSTANT to CREATE a header and compile the initial value, init,
+ (fig-forth-auto680):02380 * then overwrite the characteristic to point to DOVAR.
+180C 88 (fig-forth-auto680):02381 FCB $88
+180D 5641524941424C (fig-forth-auto680):02382 FCC 'VARIABL' ; 'VARIABLE'
+1814 C5 (fig-forth-auto680):02383 FCB $C5
+1815 17FB (fig-forth-auto680):02384 FDB NATP-7
+1817 17B917DF1C3A (fig-forth-auto680):02385 VAR FDB DOCOL,CON,PSCODE
+ (fig-forth-auto680):02386 * ( --- vadr )
+ (fig-forth-auto680):02387 * Characteristic of a VARIABLE.
+ (fig-forth-auto680):02388 * A VARIABLE pushes its PFA address on the stack.
+ (fig-forth-auto680):02389 * The parameter field of a VARIABLE is the actual allocation of the variable,
+ (fig-forth-auto680):02390 * so that pushing its address allows its contents to be @ed (fetched).
+ (fig-forth-auto680):02391 * Ordinary arrays and strings that do not subscript themselves
+ (fig-forth-auto680):02392 * may be allocated by defining a variable
+ (fig-forth-auto680):02393 * and immediately ALLOTting the remaining needed space.
+ (fig-forth-auto680):02394 * VARIABLES are global to all users,
+ (fig-forth-auto680):02395 * and thus should be hidden in resource monitors, but aren't.
+181D 3002 (fig-forth-auto680):02396 DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters.
+181F 3610 (fig-forth-auto680):02397 PSHU X
+1821 39 (fig-forth-auto680):02398 RTS
+ (fig-forth-auto680):02399 * DOVAR LDA W
+ (fig-forth-auto680):02400 * LDB W+1
+ (fig-forth-auto680):02401 * ADDB #2
+ (fig-forth-auto680):02402 * ADCA #0 A,B now contain the address of the variable
+ (fig-forth-auto680):02403 * JMP PUSHBA
+ (fig-forth-auto680):02404 *
+ (fig-forth-auto680):02405 * ======>> 51 <<
+ (fig-forth-auto680):02406 * ( ub --- )
+ (fig-forth-auto680):02407 * { uboffset USER name } typical input
+ (fig-forth-auto680):02408 * CREATE a header and compile the unsigned byte offset in the per-USER table,
+ (fig-forth-auto680):02409 * then overwrite the header with a call to DOUSER.
+ (fig-forth-auto680):02410 * The USER is entirely responsible for maintaining allocation!
+1822 84 (fig-forth-auto680):02411 FCB $84
+1823 555345 (fig-forth-auto680):02412 FCC 'USE' ; 'USER'
+1826 D2 (fig-forth-auto680):02413 FCB $D2
+1827 180C (fig-forth-auto680):02414 FDB VAR-11
+1829 17B917DF1C3A (fig-forth-auto680):02415 USER FDB DOCOL,CON,PSCODE
+ (fig-forth-auto680):02416 * ( --- vadr )
+ (fig-forth-auto680):02417 * Characteristic of a per-USER variable.
+ (fig-forth-auto680):02418 * USER variables are similiar to VARIABLEs,
+ (fig-forth-auto680):02419 * but are allocated (by hand!) in the per-user table.
+ (fig-forth-auto680):02420 * A USER variable's parameter field contains its offset in the per-user table.
+182F 1FB8 (fig-forth-auto680):02421 DOUSER TFR DP,A ; Make a pointer to the direct page.
+1831 5F (fig-forth-auto680):02422 CLRB
+ (fig-forth-auto680):02423 * See Alternative -- alternatives start from this point.
+1832 E302 (fig-forth-auto680):02424 ADDD NATWID,X ; Add it to the offset to the per-user variable.
+1834 3606 (fig-forth-auto680):02425 PSHU D
+1836 1F01 (fig-forth-auto680):02426 TFR D,X ; Cache the pointer in X for the caller.
+1838 39 (fig-forth-auto680):02427 RTS
+ (fig-forth-auto680):02428 * Hey, the per-user table could actually be larger than 256 bytes!
+ (fig-forth-auto680):02429 * But we knew that. It's just not as esthetic to calculate it this way.
+ (fig-forth-auto680):02430 * Alternative A:
+ (fig-forth-auto680):02431 * LDX NATWID,X ; Keep the offset
+ (fig-forth-auto680):02432 * EXG D,X ; Prepare for EA
+ (fig-forth-auto680):02433 * LEAX D,X
+ (fig-forth-auto680):02434 * PSHU X
+ (fig-forth-auto680):02435 * RTS
+ (fig-forth-auto680):02436 * Alternative B:
+ (fig-forth-auto680):02437 * PSHS Y ; Get Y free for calculations.
+ (fig-forth-auto680):02438 * TFR D,Y ; Y points to the UP base
+ (fig-forth-auto680):02439 * LDD NATWID,X ; Get the offset
+ (fig-forth-auto680):02440 * LEAX D,Y ; Leave the pointer cached in X.
+ (fig-forth-auto680):02441 * PSHU X
+ (fig-forth-auto680):02442 * PULS Y,PC
+ (fig-forth-auto680):02443 *
+ (fig-forth-auto680):02444 * From the 6800 model:
+ (fig-forth-auto680):02445 * DOUSER LDX W get offset into user's table
+ (fig-forth-auto680):02446 * LDA 2,X
+ (fig-forth-auto680):02447 * LDB 3,X
+ (fig-forth-auto680):02448 * ADDB UP+1 add to users base address
+ (fig-forth-auto680):02449 * ADCA UP
+ (fig-forth-auto680):02450 * JMP PUSHBA push address of user's variable
+ (fig-forth-auto680):02451 *
+ (fig-forth-auto680):02452 * ######>> screen 35 <<
+ (fig-forth-auto680):02453 * ======>> 52 <<
+ (fig-forth-auto680):02454 * ( --- 0 )
+1839 81 (fig-forth-auto680):02455 FCB $81
+183A B0 (fig-forth-auto680):02456 FCB $B0 0
+183B 1822 (fig-forth-auto680):02457 FDB USER-7
+183D 17E9 (fig-forth-auto680):02458 ZERO FDB DOCON
+183F 0000 (fig-forth-auto680):02459 FDB 0000
+ (fig-forth-auto680):02460 *
+ (fig-forth-auto680):02461 * ======>> 53 <<
+ (fig-forth-auto680):02462 * ( --- 1 )
+1841 81 (fig-forth-auto680):02463 FCB $81
+1842 B1 (fig-forth-auto680):02464 FCB $B1 1
+1843 1839 (fig-forth-auto680):02465 FDB ZERO-4
+1845 17E9 (fig-forth-auto680):02466 ONE FDB DOCON
+1847 0001 (fig-forth-auto680):02467 ONEV FDB 1
+ (fig-forth-auto680):02468 *
+ (fig-forth-auto680):02469 * ======>> 54 <<
+ (fig-forth-auto680):02470 * ( --- 2 )
+1849 81 (fig-forth-auto680):02471 FCB $81
+184A B2 (fig-forth-auto680):02472 FCB $B2 2
+184B 1841 (fig-forth-auto680):02473 FDB ONE-4
+184D 17E9 (fig-forth-auto680):02474 TWO FDB DOCON
+184F 0002 (fig-forth-auto680):02475 TWOV FDB 2
+ (fig-forth-auto680):02476 *
+ (fig-forth-auto680):02477 * ======>> 55 <<
+ (fig-forth-auto680):02478 * ( --- 3 )
+1851 81 (fig-forth-auto680):02479 FCB $81
+1852 B3 (fig-forth-auto680):02480 FCB $B3 3
+1853 1849 (fig-forth-auto680):02481 FDB TWO-4
+1855 17E9 (fig-forth-auto680):02482 THREE FDB DOCON
+1857 0003 (fig-forth-auto680):02483 FDB 3
+ (fig-forth-auto680):02484 *
+ (fig-forth-auto680):02485 * ======>> 56 <<
+ (fig-forth-auto680):02486 * ( --- SP )
+ (fig-forth-auto680):02487 * ASCII SPACE character
+1859 82 (fig-forth-auto680):02488 FCB $82
+185A 42 (fig-forth-auto680):02489 FCC 'B' ; 'BL'
+185B CC (fig-forth-auto680):02490 FCB $CC
+185C 1851 (fig-forth-auto680):02491 FDB THREE-4
+185E 17E9 (fig-forth-auto680):02492 BL FDB DOCON ascii blank
+1860 0020 (fig-forth-auto680):02493 FDB $20
+ (fig-forth-auto680):02494 *
+ (fig-forth-auto680):02495 * ======>> 57 <<
+ (fig-forth-auto680):02496 * This really shouldn't be a CONSTANT.
+ (fig-forth-auto680):02497 * ( --- adr )
+ (fig-forth-auto680):02498 * The base of the disk buffer space.
+1862 85 (fig-forth-auto680):02499 FCB $85
+1863 46495253 (fig-forth-auto680):02500 FCC 'FIRS' ; 'FIRST'
+1867 D4 (fig-forth-auto680):02501 FCB $D4
+1868 1859 (fig-forth-auto680):02502 FDB BL-5
+186A 17E9 (fig-forth-auto680):02503 FIRST FDB DOCON
+186C 6BE0 (fig-forth-auto680):02504 FDB BUFBAS
+ (fig-forth-auto680):02505 * FDB MEMEND-528 (132 * NBLK)
+ (fig-forth-auto680):02506 *
+ (fig-forth-auto680):02507 * ======>> 58 <<
+ (fig-forth-auto680):02508 * This really shouldn't be a CONSTANT.
+ (fig-forth-auto680):02509 * ( --- adr )
+ (fig-forth-auto680):02510 * The limit of the disk buffer space.
+186E 85 (fig-forth-auto680):02511 FCB $85
+186F 4C494D49 (fig-forth-auto680):02512 FCC 'LIMI' ; 'LIMIT' : ( the end of memory +1 )
+1873 D4 (fig-forth-auto680):02513 FCB $D4
+1874 1862 (fig-forth-auto680):02514 FDB FIRST-8
+1876 17E9 (fig-forth-auto680):02515 LIMIT FDB DOCON
+1878 7000 (fig-forth-auto680):02516 FDB BUFBAS+BUFSZ
+ (fig-forth-auto680):02517 * In 6800 model, was
+ (fig-forth-auto680):02518 * FDB MEMEND
+ (fig-forth-auto680):02519 *
+ (fig-forth-auto680):02520 * ======>> 59 <<
+ (fig-forth-auto680):02521 * ( --- sectorsize )
+ (fig-forth-auto680):02522 * The size, in bytes, of a buffer.
+187A 85 (fig-forth-auto680):02523 FCB $85
+187B 422F4255 (fig-forth-auto680):02524 FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
+187F C6 (fig-forth-auto680):02525 FCB $C6
+1880 186E (fig-forth-auto680):02526 FDB LIMIT-8
+1882 17E9 (fig-forth-auto680):02527 BBUF FDB DOCON
+1884 0100 (fig-forth-auto680):02528 FDB SECTSZ
+ (fig-forth-auto680):02529 * Hardcoded in 6800 model:
+ (fig-forth-auto680):02530 * FDB 128
+ (fig-forth-auto680):02531 *
+ (fig-forth-auto680):02532 * ======>> 60 <<
+ (fig-forth-auto680):02533 * ( --- blocksperscreen )
+ (fig-forth-auto680):02534 * The size, in blocks, of a screen.
+ (fig-forth-auto680):02535 * Should this be the same as NBLK, the number of block buffers maintained?
+1886 85 (fig-forth-auto680):02536 FCB $85
+1887 422F5343 (fig-forth-auto680):02537 FCC 'B/SC' ; 'B/SCR' : (blocks/screen)
+188B D2 (fig-forth-auto680):02538 FCB $D2
+188C 187A (fig-forth-auto680):02539 FDB BBUF-8
+188E 17E9 (fig-forth-auto680):02540 BSCR FDB DOCON
+1890 0004 (fig-forth-auto680):02541 FDB SCRSZ/SECTSZ
+ (fig-forth-auto680):02542 * Hardcoded in 6800 model as:
+ (fig-forth-auto680):02543 * FDB 8
+ (fig-forth-auto680):02544 * blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
+ (fig-forth-auto680):02545 *
+ (fig-forth-auto680):02546 * ======>> 61 <<
+ (fig-forth-auto680):02547 * ( n --- adr )
+ (fig-forth-auto680):02548 * Calculate the address of entry (#n/2) in the boot-up parameter table.
+ (fig-forth-auto680):02549 * (Adds the base of the boot-up table to n.)
+1892 87 (fig-forth-auto680):02550 FCB $87
+1893 2B4F52494749 (fig-forth-auto680):02551 FCC '+ORIGI' ; '+ORIGIN'
+1899 CE (fig-forth-auto680):02552 FCB $CE
+189A 1886 (fig-forth-auto680):02553 FDB BSCR-8
+189C 17B91399120016C6 (fig-forth-auto680):02554 PORIG FDB DOCOL,LIT,ORIG,PLUS
+18A4 1667 (fig-forth-auto680):02555 FDB SEMIS
+ (fig-forth-auto680):02556 *
+ (fig-forth-auto680):02557 * ######>> screen 36 <<
+ (fig-forth-auto680):02558 * ======>> 62 <<
+ (fig-forth-auto680):02559 * ( n --- adr )
+ (fig-forth-auto680):02560 * This is the per-task variable recording the initial parameter stack pointer.
+18A6 82 (fig-forth-auto680):02561 FCB $82
+18A7 53 (fig-forth-auto680):02562 FCC 'S' ; 'S0'
+18A8 B0 (fig-forth-auto680):02563 FCB $B0
+18A9 1892 (fig-forth-auto680):02564 FDB PORIG-10
+18AB 182F (fig-forth-auto680):02565 SZERO FDB DOUSER
+18AD 001E (fig-forth-auto680):02566 FDB XSPZER-UORIG
+ (fig-forth-auto680):02567 *
+ (fig-forth-auto680):02568 * ======>> 63 <<
+ (fig-forth-auto680):02569 * ( n --- adr )
+ (fig-forth-auto680):02570 * This is the per-task variable recording the initial return stack pointer.
+18AF 82 (fig-forth-auto680):02571 FCB $82
+18B0 52 (fig-forth-auto680):02572 FCC 'R' ; 'R0'
+18B1 B0 (fig-forth-auto680):02573 FCB $B0
+18B2 18A6 (fig-forth-auto680):02574 FDB SZERO-5
+18B4 182F (fig-forth-auto680):02575 RZERO FDB DOUSER
+18B6 0020 (fig-forth-auto680):02576 FDB XRZERO-UORIG
+ (fig-forth-auto680):02577 *
+ (fig-forth-auto680):02578 * ======>> 64 <<
+ (fig-forth-auto680):02579 * ( --- vadr )
+ (fig-forth-auto680):02580 * Terminal Input Buffer address.
+ (fig-forth-auto680):02581 * Note that this is a variable, so users may allocate their own buffers, but it must be @ed.
+18B8 83 (fig-forth-auto680):02582 FCB $83
+18B9 5449 (fig-forth-auto680):02583 FCC 'TI' ; 'TIB'
+18BB C2 (fig-forth-auto680):02584 FCB $C2
+18BC 18AF (fig-forth-auto680):02585 FDB RZERO-5
+18BE 182F (fig-forth-auto680):02586 TIB FDB DOUSER
+18C0 0022 (fig-forth-auto680):02587 FDB XTIB-UORIG
+ (fig-forth-auto680):02588 *
+ (fig-forth-auto680):02589 * ======>> 65 <<
+ (fig-forth-auto680):02590 * ( --- maxnamewidth )
+ (fig-forth-auto680):02591 * This is the maximum width to which symbol names will be recorded.
+18C2 85 (fig-forth-auto680):02592 FCB $85
+18C3 57494454 (fig-forth-auto680):02593 FCC 'WIDT' ; 'WIDTH'
+18C7 C8 (fig-forth-auto680):02594 FCB $C8
+18C8 18B8 (fig-forth-auto680):02595 FDB TIB-6
+18CA 182F (fig-forth-auto680):02596 WIDTH FDB DOUSER
+18CC 0024 (fig-forth-auto680):02597 FDB XWIDTH-UORIG
+ (fig-forth-auto680):02598 *
+ (fig-forth-auto680):02599 * ======>> 66 <<
+ (fig-forth-auto680):02600 * ( --- vadr )
+ (fig-forth-auto680):02601 * Availability of error messages on disk.
+ (fig-forth-auto680):02602 * Contains 1 if messages available,
+ (fig-forth-auto680):02603 * 0 if not,
+ (fig-forth-auto680):02604 * -1 if a disk error has occurred.
+18CE 87 (fig-forth-auto680):02605 FCB $87
+18CF 5741524E494E (fig-forth-auto680):02606 FCC 'WARNIN' ; 'WARNING'
+18D5 C7 (fig-forth-auto680):02607 FCB $C7
+18D6 18C2 (fig-forth-auto680):02608 FDB WIDTH-8
+18D8 182F (fig-forth-auto680):02609 WARN FDB DOUSER
+18DA 0026 (fig-forth-auto680):02610 FDB XWARN-UORIG
+ (fig-forth-auto680):02611 *
+ (fig-forth-auto680):02612 * ======>> 67 <<
+ (fig-forth-auto680):02613 * ( --- vadr )
+ (fig-forth-auto680):02614 * Boundary for FORGET.
+18DC 85 (fig-forth-auto680):02615 FCB $85
+18DD 46454E43 (fig-forth-auto680):02616 FCC 'FENC' ; 'FENCE'
+18E1 C5 (fig-forth-auto680):02617 FCB $C5
+18E2 18CE (fig-forth-auto680):02618 FDB WARN-10
+18E4 182F (fig-forth-auto680):02619 FENCE FDB DOUSER
+18E6 0028 (fig-forth-auto680):02620 FDB XFENCE-UORIG
+ (fig-forth-auto680):02621 *
+ (fig-forth-auto680):02622 * ======>> 68 <<
+ (fig-forth-auto680):02623 * ( --- vadr )
+ (fig-forth-auto680):02624 * Dictionary pointer, fetched by HERE.
+18E8 82 (fig-forth-auto680):02625 FCB $82
+18E9 44 (fig-forth-auto680):02626 FCC 'D' ; 'DP' : points to first free byte at end of dictionary
+18EA D0 (fig-forth-auto680):02627 FCB $D0
+18EB 18DC (fig-forth-auto680):02628 FDB FENCE-8
+18ED 182F (fig-forth-auto680):02629 DICTPT FDB DOUSER
+18EF 002A (fig-forth-auto680):02630 FDB XDICTP-UORIG
+ (fig-forth-auto680):02631 *
+ (fig-forth-auto680):02632 * ======>> 68.5 <<
+ (fig-forth-auto680):02633 * ( --- vadr ) ******* Need to check what this is!
+ (fig-forth-auto680):02634 * Used in maintaining vocabularies.
+ (fig-forth-auto680):02635 * I think it points to the "parent" vocabulary, but I'm not sure.
+ (fig-forth-auto680):02636 * Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
+18F1 88 (fig-forth-auto680):02637 FCB $88
+18F2 564F432D4C494E (fig-forth-auto680):02638 FCC 'VOC-LIN' ; 'VOC-LINK'
+18F9 CB (fig-forth-auto680):02639 FCB $CB
+18FA 18E8 (fig-forth-auto680):02640 FDB DICTPT-5
+18FC 182F (fig-forth-auto680):02641 VOCLIN FDB DOUSER
+18FE 002C (fig-forth-auto680):02642 FDB XVOCL-UORIG
+ (fig-forth-auto680):02643 *
+ (fig-forth-auto680):02644 * ======>> 69 <<
+ (fig-forth-auto680):02645 * ( --- vadr )
+ (fig-forth-auto680):02646 * Disk block being interpreted.
+ (fig-forth-auto680):02647 * Zero refers to terminal.
+ (fig-forth-auto680):02648 * ******** Should be made a 32 bit user variable! ********
+ (fig-forth-auto680):02649 * But the base system needs to have full 32 bit support, div and mul, etc.
+ (fig-forth-auto680):02650 * before we can do that.
+1900 83 (fig-forth-auto680):02651 FCB $83
+1901 424C (fig-forth-auto680):02652 FCC 'BL' ; 'BLK'
+1903 CB (fig-forth-auto680):02653 FCB $CB
+1904 18F1 (fig-forth-auto680):02654 FDB VOCLIN-11
+1906 182F (fig-forth-auto680):02655 BLK FDB DOUSER
+1908 002E (fig-forth-auto680):02656 FDB XBLK-UORIG
+ (fig-forth-auto680):02657 *
+ (fig-forth-auto680):02658 * ======>> 70 <<
+ (fig-forth-auto680):02659 * ( --- vadr )
+ (fig-forth-auto680):02660 * Input buffer offset/cursor.
+190A 82 (fig-forth-auto680):02661 FCB $82
+190B 49 (fig-forth-auto680):02662 FCC 'I' ; 'IN' : scan pointer for input line buffer
+190C CE (fig-forth-auto680):02663 FCB $CE
+190D 1900 (fig-forth-auto680):02664 FDB BLK-6
+190F 182F (fig-forth-auto680):02665 IN FDB DOUSER
+1911 0030 (fig-forth-auto680):02666 FDB XIN-UORIG
+ (fig-forth-auto680):02667 *
+ (fig-forth-auto680):02668 * ======>> 71 <<
+ (fig-forth-auto680):02669 * ( --- vadr )
+ (fig-forth-auto680):02670 * Output buffer offset/cursor.
+1913 83 (fig-forth-auto680):02671 FCB $83
+1914 4F55 (fig-forth-auto680):02672 FCC 'OU' ; 'OUT'
+1916 D4 (fig-forth-auto680):02673 FCB $D4
+1917 190A (fig-forth-auto680):02674 FDB IN-5
+1919 182F (fig-forth-auto680):02675 OUT FDB DOUSER
+191B 0032 (fig-forth-auto680):02676 FDB XOUT-UORIG
+ (fig-forth-auto680):02677 *
+ (fig-forth-auto680):02678 * ======>> 72 <<
+ (fig-forth-auto680):02679 * ( --- vadr )
+ (fig-forth-auto680):02680 * Screen currently being edited, once we have an editor running.
+191D 83 (fig-forth-auto680):02681 FCB $83
+191E 5343 (fig-forth-auto680):02682 FCC 'SC' ; 'SCR'
+1920 D2 (fig-forth-auto680):02683 FCB $D2
+1921 1913 (fig-forth-auto680):02684 FDB OUT-6
+1923 182F (fig-forth-auto680):02685 SCR FDB DOUSER
+1925 0034 (fig-forth-auto680):02686 FDB XSCR-UORIG
+ (fig-forth-auto680):02687 * ######>> screen 37 <<
+ (fig-forth-auto680):02688 *
+ (fig-forth-auto680):02689 * ======>> 73 <<
+ (fig-forth-auto680):02690 * ( --- vadr )
+ (fig-forth-auto680):02691 * Sector offset for LOADing screens,
+ (fig-forth-auto680):02692 * set by DRIVE to make a new drive the default.
+ (fig-forth-auto680):02693 * This should also be 32 bit or bigger.
+1927 86 (fig-forth-auto680):02694 FCB $86
+1928 4F46465345 (fig-forth-auto680):02695 FCC 'OFFSE' ; 'OFFSET'
+192D D4 (fig-forth-auto680):02696 FCB $D4
+192E 191D (fig-forth-auto680):02697 FDB SCR-6
+1930 182F (fig-forth-auto680):02698 OFSET FDB DOUSER
+1932 0036 (fig-forth-auto680):02699 FDB XOFSET-UORIG
+ (fig-forth-auto680):02700 *
+ (fig-forth-auto680):02701 * ======>> 74 <<
+ (fig-forth-auto680):02702 * ( --- vadr )
+ (fig-forth-auto680):02703 * Current context of interpretation (vocabulary root).
+1934 87 (fig-forth-auto680):02704 FCB $87
+1935 434F4E544558 (fig-forth-auto680):02705 FCC 'CONTEX' ; 'CONTEXT' : points to pointer to vocab to search first
+193B D4 (fig-forth-auto680):02706 FCB $D4
+193C 1927 (fig-forth-auto680):02707 FDB OFSET-9
+193E 182F (fig-forth-auto680):02708 CONTXT FDB DOUSER
+1940 0038 (fig-forth-auto680):02709 FDB XCONT-UORIG
+ (fig-forth-auto680):02710 *
+ (fig-forth-auto680):02711 * ======>> 75 <<
+ (fig-forth-auto680):02712 * ( --- vadr )
+ (fig-forth-auto680):02713 * Current context of definition (vocabulary root).
+1942 87 (fig-forth-auto680):02714 FCB $87
+1943 43555252454E (fig-forth-auto680):02715 FCC 'CURREN' ; 'CURRENT' : points to ptr. to vocab being extended
+1949 D4 (fig-forth-auto680):02716 FCB $D4
+194A 1934 (fig-forth-auto680):02717 FDB CONTXT-10
+194C 182F (fig-forth-auto680):02718 CURENT FDB DOUSER
+194E 003A (fig-forth-auto680):02719 FDB XCURR-UORIG
+ (fig-forth-auto680):02720 *
+ (fig-forth-auto680):02721 * ======>> 76 <<
+ (fig-forth-auto680):02722 * ( --- vadr )
+ (fig-forth-auto680):02723 * Compiler/interpreter state.
+1950 85 (fig-forth-auto680):02724 FCB $85
+1951 53544154 (fig-forth-auto680):02725 FCC 'STAT' ; 'STATE' : 1 if compiling, 0 if not
+1955 C5 (fig-forth-auto680):02726 FCB $C5
+1956 1942 (fig-forth-auto680):02727 FDB CURENT-10
+1958 182F (fig-forth-auto680):02728 STATE FDB DOUSER
+195A 003C (fig-forth-auto680):02729 FDB XSTATE-UORIG
+ (fig-forth-auto680):02730 *
+ (fig-forth-auto680):02731 * ======>> 77 <<
+ (fig-forth-auto680):02732 * ( --- vadr )
+ (fig-forth-auto680):02733 * Numeric conversion base.
+195C 84 (fig-forth-auto680):02734 FCB $84
+195D 424153 (fig-forth-auto680):02735 FCC 'BAS' ; 'BASE' : number base for all input & output
+1960 C5 (fig-forth-auto680):02736 FCB $C5
+1961 1950 (fig-forth-auto680):02737 FDB STATE-8
+1963 182F (fig-forth-auto680):02738 BASE FDB DOUSER
+1965 003E (fig-forth-auto680):02739 FDB XBASE-UORIG
+ (fig-forth-auto680):02740 *
+ (fig-forth-auto680):02741 * ======>> 78 <<
+ (fig-forth-auto680):02742 * ( --- vadr )
+ (fig-forth-auto680):02743 * Decimal point location for output.
+1967 83 (fig-forth-auto680):02744 FCB $83
+1968 4450 (fig-forth-auto680):02745 FCC 'DP' ; 'DPL'
+196A CC (fig-forth-auto680):02746 FCB $CC
+196B 195C (fig-forth-auto680):02747 FDB BASE-7
+196D 182F (fig-forth-auto680):02748 DPL FDB DOUSER
+196F 0040 (fig-forth-auto680):02749 FDB XDPL-UORIG
+ (fig-forth-auto680):02750 *
+ (fig-forth-auto680):02751 * ======>> 79 <<
+ (fig-forth-auto680):02752 * ( --- vadr )
+ (fig-forth-auto680):02753 * Field width for I/O formatting.
+1971 83 (fig-forth-auto680):02754 FCB $83
+1972 464C (fig-forth-auto680):02755 FCC 'FL' ; 'FLD'
+1974 C4 (fig-forth-auto680):02756 FCB $C4
+1975 1967 (fig-forth-auto680):02757 FDB DPL-6
+1977 182F (fig-forth-auto680):02758 FLD FDB DOUSER
+1979 0042 (fig-forth-auto680):02759 FDB XFLD-UORIG
+ (fig-forth-auto680):02760 *
+ (fig-forth-auto680):02761 * ======>> 80 <<
+ (fig-forth-auto680):02762 * ( --- vadr )
+ (fig-forth-auto680):02763 * Compiler stack mark for stack check.
+197B 83 (fig-forth-auto680):02764 FCB $83
+197C 4353 (fig-forth-auto680):02765 FCC 'CS' ; 'CSP'
+197E D0 (fig-forth-auto680):02766 FCB $D0
+197F 1971 (fig-forth-auto680):02767 FDB FLD-6
+1981 182F (fig-forth-auto680):02768 CSP FDB DOUSER
+1983 0044 (fig-forth-auto680):02769 FDB XCSP-UORIG
+ (fig-forth-auto680):02770 *
+ (fig-forth-auto680):02771 * ======>> 81 <<
+ (fig-forth-auto680):02772 * ( --- vadr )
+ (fig-forth-auto680):02773 * Editing cursor location.
+1985 82 (fig-forth-auto680):02774 FCB $82
+1986 52 (fig-forth-auto680):02775 FCC 'R' ; 'R#'
+1987 A3 (fig-forth-auto680):02776 FCB $A3
+1988 197B (fig-forth-auto680):02777 FDB CSP-6
+198A 182F (fig-forth-auto680):02778 RNUM FDB DOUSER
+198C 0046 (fig-forth-auto680):02779 FDB XRNUM-UORIG
+ (fig-forth-auto680):02780 *
+ (fig-forth-auto680):02781 * ======>> 82 <<
+ (fig-forth-auto680):02782 * ( --- vadr )
+ (fig-forth-auto680):02783 * Pointer to last HELD character in PAD.
+198E 83 (fig-forth-auto680):02784 FCB $83
+198F 484C (fig-forth-auto680):02785 FCC 'HL' ; 'HLD'
+1991 C4 (fig-forth-auto680):02786 FCB $C4
+1992 1985 (fig-forth-auto680):02787 FDB RNUM-5
+1994 17E9 (fig-forth-auto680):02788 HLD FDB DOCON
+1996 7C48 (fig-forth-auto680):02789 FDB XHLD
+ (fig-forth-auto680):02790 *
+ (fig-forth-auto680):02791 * ======>> 82.5 <<== SPECIAL
+ (fig-forth-auto680):02792 * ( --- vadr )
+ (fig-forth-auto680):02793 * Line width of active terminal.
+1998 87 (fig-forth-auto680):02794 FCB $87
+1999 434F4C554D4E (fig-forth-auto680):02795 FCC 'COLUMN' ; 'COLUMNS' : line width of terminal
+199F D3 (fig-forth-auto680):02796 FCB $D3
+19A0 198E (fig-forth-auto680):02797 FDB HLD-6
+19A2 182F (fig-forth-auto680):02798 COLUMS FDB DOUSER
+19A4 004C (fig-forth-auto680):02799 FDB XCOLUM-UORIG
+ (fig-forth-auto680):02800 *
+ (fig-forth-auto680):02801 * ######>> screen 38 <<
+ (fig-forth-auto680):02802 **
+ (fig-forth-auto680):02803 ** An INCREMENTER probably should not be defined without a defined CONSTANT?
+ (fig-forth-auto680):02804 **
+ (fig-forth-auto680):02805 ** Make an INCREMENTER compiling word (not in model):
+ (fig-forth-auto680):02806 ** ( n --- )
+ (fig-forth-auto680):02807 ** { n INCREMENTER name } typical input
+ (fig-forth-auto680):02808 ** CREATE a header and compile the increment constant,
+ (fig-forth-auto680):02809 ** then overwrite the header with a call to DOINC.
+ (fig-forth-auto680):02810 * FCB $8B
+ (fig-forth-auto680):02811 * FCC 'INCREMENTE' ; 'INCREMENTER'
+ (fig-forth-auto680):02812 * FCB $D2
+ (fig-forth-auto680):02813 * FDB COLUMS-10
+ (fig-forth-auto680):02814 * INCR FDB DOCOL,CON,PSCODE
+ (fig-forth-auto680):02815 ** ( n --- ninc )
+ (fig-forth-auto680):02816 ** Characteristic of an INCREMENTER.
+ (fig-forth-auto680):02817 ** This is too naive:
+ (fig-forth-auto680):02818 * DOINC LDD ,U
+ (fig-forth-auto680):02819 * ADDD NATWID,X ; Add the increment.
+ (fig-forth-auto680):02820 * STD ,U
+ (fig-forth-auto680):02821 * RTS
+ (fig-forth-auto680):02822 * Compiling word should check that it is compiling a CONSTANT.
+ (fig-forth-auto680):02823 *
+ (fig-forth-auto680):02824 * ======>> 83 <<
+ (fig-forth-auto680):02825 * ( n --- n+1 )
+19A6 82 (fig-forth-auto680):02826 FCB $82
+19A7 31 (fig-forth-auto680):02827 FCC '1' ; '1+'
+19A8 AB (fig-forth-auto680):02828 FCB $AB
+19A9 1998 (fig-forth-auto680):02829 FDB COLUMS-10
+ (fig-forth-auto680):02830 * Using the model keeps things semantically connected for other processors:
+19AB 17B9184516C6 (fig-forth-auto680):02831 ONEP FDB DOCOL,ONE,PLUS
+19B1 1667 (fig-forth-auto680):02832 FDB SEMIS
+ (fig-forth-auto680):02833 ** Greedy alternative:
+ (fig-forth-auto680):02834 * ONEP FDB *+NATWID
+ (fig-forth-auto680):02835 * LDD ,U
+ (fig-forth-auto680):02836 * ADDD ONEV,PCR
+ (fig-forth-auto680):02837 * STD ,U
+ (fig-forth-auto680):02838 * RTS
+ (fig-forth-auto680):02839 * Naive alternative:
+ (fig-forth-auto680):02840 * ONEP FDB DOINC
+ (fig-forth-auto680):02841 * FDB 1
+ (fig-forth-auto680):02842 * Naive alternative:
+ (fig-forth-auto680):02843 * ONEP FDB *+NATWID
+ (fig-forth-auto680):02844 * LDD ,U
+ (fig-forth-auto680):02845 * ADDD #1 ; It's hard to imagine 1+ being other than 1.
+ (fig-forth-auto680):02846 * STD ,U
+ (fig-forth-auto680):02847 * RTS
+ (fig-forth-auto680):02848 *
+ (fig-forth-auto680):02849 * ======>> 84 <<
+ (fig-forth-auto680):02850 * ( n --- n+2 )
+19B3 82 (fig-forth-auto680):02851 FCB $82
+19B4 32 (fig-forth-auto680):02852 FCC '2' ; '2+'
+19B5 AB (fig-forth-auto680):02853 FCB $AB
+19B6 19A6 (fig-forth-auto680):02854 FDB ONEP-5
+ (fig-forth-auto680):02855 * Using the model keeps things semantically connected for other processors:
+19B8 17B9184D16C6 (fig-forth-auto680):02856 TWOP FDB DOCOL,TWO,PLUS
+19BE 1667 (fig-forth-auto680):02857 FDB SEMIS
+ (fig-forth-auto680):02858 ** Greedy alternative:
+ (fig-forth-auto680):02859 * TWOP FDB *+NATWID
+ (fig-forth-auto680):02860 * LDD ,U
+ (fig-forth-auto680):02861 * ADDD TWOV,PCR ; See NAT+ (NATP)
+ (fig-forth-auto680):02862 * STD ,U
+ (fig-forth-auto680):02863 * RTS
+ (fig-forth-auto680):02864 * Naive alternative:
+ (fig-forth-auto680):02865 * TWOP FDB DOINC
+ (fig-forth-auto680):02866 * FDB 2
+ (fig-forth-auto680):02867 * Naive alternative:
+ (fig-forth-auto680):02868 * TWOP FDB *+NATWID
+ (fig-forth-auto680):02869 * LDD ,U
+ (fig-forth-auto680):02870 * ADDD #2 ; See NAT+ (NATP)
+ (fig-forth-auto680):02871 * STD ,U
+ (fig-forth-auto680):02872 * RTS
+ (fig-forth-auto680):02873 *
+ (fig-forth-auto680):02874 * ======>> 85 <<
+ (fig-forth-auto680):02875 * ( --- adr )
+ (fig-forth-auto680):02876 * Get the DICTPT allocation, like a USER constant.
+ (fig-forth-auto680):02877 * Should check the stack and heap for collision.
+19C0 84 (fig-forth-auto680):02878 FCB $84
+19C1 484552 (fig-forth-auto680):02879 FCC 'HER' ; 'HERE'
+19C4 C5 (fig-forth-auto680):02880 FCB $C5
+19C5 19B3 (fig-forth-auto680):02881 FDB TWOP-5
+19C7 17B918ED1772 (fig-forth-auto680):02882 HERE FDB DOCOL,DICTPT,AT
+19CD 1667 (fig-forth-auto680):02883 FDB SEMIS
+ (fig-forth-auto680):02884 *
+ (fig-forth-auto680):02885 * ======>> 86 <<
+ (fig-forth-auto680):02886 * ( n --- )
+ (fig-forth-auto680):02887 * Increase/decrease heap (add n to DP),
+ (fig-forth-auto680):02888 * Should ERROR check stack/heap.
+19CF 85 (fig-forth-auto680):02889 FCB $85
+19D0 414C4C4F (fig-forth-auto680):02890 FCC 'ALLO' ; 'ALLOT'
+19D4 D4 (fig-forth-auto680):02891 FCB $D4
+19D5 19C0 (fig-forth-auto680):02892 FDB HERE-7
+19D7 17B918ED1751 (fig-forth-auto680):02893 ALLOT FDB DOCOL,DICTPT,PSTORE
+19DD 1667 (fig-forth-auto680):02894 FDB SEMIS
+ (fig-forth-auto680):02895 *
+ (fig-forth-auto680):02896 * ======>> 87 <<
+ (fig-forth-auto680):02897 * ( n --- )
+ (fig-forth-auto680):02898 * Store word n at DP++,
+ (fig-forth-auto680):02899 * Should ERROR check stack/heap.
+19DF 81 (fig-forth-auto680):02900 FCB $81 ; , (COMMA)
+19E0 AC (fig-forth-auto680):02901 FCB $AC
+19E1 19CF (fig-forth-auto680):02902 FDB ALLOT-8
+19E3 17B919C7178A17F7 (fig-forth-auto680):02903 COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT
+ 19D7
+19ED 1667 (fig-forth-auto680):02904 FDB SEMIS
+ (fig-forth-auto680):02905 * COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
+ (fig-forth-auto680):02906 * FDB SEMIS
+ (fig-forth-auto680):02907 *
+ (fig-forth-auto680):02908 * ======>> 88 <<
+ (fig-forth-auto680):02909 * ( b --- )
+ (fig-forth-auto680):02910 * Store byte b at DP+,
+ (fig-forth-auto680):02911 * Should ERROR check stack/heap.
+19EF 82 (fig-forth-auto680):02912 FCB $82
+19F0 43 (fig-forth-auto680):02913 FCC 'C' ; 'C,'
+19F1 AC (fig-forth-auto680):02914 FCB $AC
+19F2 19DF (fig-forth-auto680):02915 FDB COMMA-4
+19F4 17B919C717981845 (fig-forth-auto680):02916 CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
+ 19D7
+19FE 1667 (fig-forth-auto680):02917 FDB SEMIS
+ (fig-forth-auto680):02918 *
+ (fig-forth-auto680):02919 * ======>> 89 <<
+ (fig-forth-auto680):02920 * ( n1 n2 --- n1-n2 )
+ (fig-forth-auto680):02921 * Subtract top two words.
+1A00 81 (fig-forth-auto680):02922 FCB $81 ; -
+1A01 AD (fig-forth-auto680):02923 FCB $AD
+1A02 19EF (fig-forth-auto680):02924 FDB CCOMM-5
+1A04 1A06 (fig-forth-auto680):02925 SUB FDB *+NATWID
+1A06 EC42 (fig-forth-auto680):02926 LDD NATWID,U ; #2~6
+1A08 A3C1 (fig-forth-auto680):02927 SUBD ,U++ ; #2~9
+1A0A EDC4 (fig-forth-auto680):02928 STD ,U ; #2~5
+1A0C 39 (fig-forth-auto680):02929 RTS ; #1~5 = #7~25
+ (fig-forth-auto680):02930 * SUB FDB DOCOL,MINUS,PLUS
+ (fig-forth-auto680):02931 * FDB SEMIS ; Costs 6 bytes and lots of cycles.
+ (fig-forth-auto680):02932 *
+ (fig-forth-auto680):02933 * ======>> 90 <<
+ (fig-forth-auto680):02934 * ( n1 n2 --- n1==n2 )
+ (fig-forth-auto680):02935 * Return flag true if n1 and n2 are equal, otherwise false.
+1A0D 81 (fig-forth-auto680):02936 FCB $81 =
+1A0E BD (fig-forth-auto680):02937 FCB $BD
+1A0F 1A00 (fig-forth-auto680):02938 FDB SUB-4
+1A11 17B91A0416A3 (fig-forth-auto680):02939 EQUAL FDB DOCOL,SUB,ZEQU
+1A17 1667 (fig-forth-auto680):02940 FDB SEMIS
+ (fig-forth-auto680):02941 *
+ (fig-forth-auto680):02942 * ======>> 91 <<
+ (fig-forth-auto680):02943 * ( n1 n2 --- n1<n2 )
+ (fig-forth-auto680):02944 * Return flag true if n1 is less than n2, otherwise false.
+1A19 81 (fig-forth-auto680):02945 FCB $81 <
+1A1A BC (fig-forth-auto680):02946 FCB $BC
+1A1B 1A0D (fig-forth-auto680):02947 FDB EQUAL-4
+1A1D 1A1F (fig-forth-auto680):02948 LESS FDB *+NATWID
+1A1F EC42 (fig-forth-auto680):02949 LDD NATWID,U
+1A21 A3C1 (fig-forth-auto680):02950 SUBD ,U++
+1A23 2C06 (fig-forth-auto680):02951 BGE FALSE
+1A25 CC0001 (fig-forth-auto680):02952 TRUE LDD #1
+1A28 EDC4 (fig-forth-auto680):02953 STD ,U
+1A2A 39 (fig-forth-auto680):02954 RTS
+1A2B CC0000 (fig-forth-auto680):02955 FALSE LDD #0
+1A2E EDC4 (fig-forth-auto680):02956 STD ,U
+1A30 39 (fig-forth-auto680):02957 RTS
+ (fig-forth-auto680):02958 * PULS A ;
+ (fig-forth-auto680):02959 * PULS B ;
+ (fig-forth-auto680):02960 * TFR S,X ; TSX :
+ (fig-forth-auto680):02961 * CMPA 0,X
+ (fig-forth-auto680):02962 * LEAS 1,S ;
+ (fig-forth-auto680):02963 * BGT LESST
+ (fig-forth-auto680):02964 * BNE LESSF
+ (fig-forth-auto680):02965 * CMPB 1,X ; Why not sub, sbc, bge?
+ (fig-forth-auto680):02966 * BHI LESST
+ (fig-forth-auto680):02967 * LESSF CLRB ;
+ (fig-forth-auto680):02968 * BRA LESSX
+ (fig-forth-auto680):02969 * LESST LDB #1
+ (fig-forth-auto680):02970 * LESSX CLRA ;
+ (fig-forth-auto680):02971 * LEAS 1,S ;
+ (fig-forth-auto680):02972 * JMP PUSHBA
+ (fig-forth-auto680):02973 *
+ (fig-forth-auto680):02974 * ======>> 92 <<
+ (fig-forth-auto680):02975 * ( n1 n2 --- n1>n2 )
+ (fig-forth-auto680):02976 * Return flag true if n1 is greater than n2, false otherwise.
+1A31 81 (fig-forth-auto680):02977 FCB $81 >
+1A32 BE (fig-forth-auto680):02978 FCB $BE
+1A33 1A19 (fig-forth-auto680):02979 FDB LESS-4
+1A35 17B917361A1D (fig-forth-auto680):02980 GREAT FDB DOCOL,SWAP,LESS
+1A3B 1667 (fig-forth-auto680):02981 FDB SEMIS
+ (fig-forth-auto680):02982 *
+ (fig-forth-auto680):02983 * ======>> 93 <<
+ (fig-forth-auto680):02984 * ( n1 n2 n3 --- n2 n3 n1 )
+ (fig-forth-auto680):02985 * Rotate the top three words on stack,
+ (fig-forth-auto680):02986 * bringing the third word to the top.
+1A3D 83 (fig-forth-auto680):02987 FCB $83
+1A3E 524F (fig-forth-auto680):02988 FCC 'RO' ; 'ROT'
+1A40 D4 (fig-forth-auto680):02989 FCB $D4
+1A41 1A31 (fig-forth-auto680):02990 FDB GREAT-4
+1A43 1A45 (fig-forth-auto680):02991 ROT FDB *+NATWID
+1A45 3420 (fig-forth-auto680):02992 PSHS Y
+1A47 3736 (fig-forth-auto680):02993 PULU D,X,Y
+1A49 3616 (fig-forth-auto680):02994 PSHU D,X
+1A4B 3620 (fig-forth-auto680):02995 PSHU Y
+1A4D 35A0 (fig-forth-auto680):02996 PULS Y,PC
+ (fig-forth-auto680):02997 * ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
+ (fig-forth-auto680):02998 * FDB SEMIS
+ (fig-forth-auto680):02999 *
+ (fig-forth-auto680):03000 * ======>> 94 <<
+ (fig-forth-auto680):03001 * ( --- )
+ (fig-forth-auto680):03002 * EMIT a SPACE.
+1A4F 85 (fig-forth-auto680):03003 FCB $85
+1A50 53504143 (fig-forth-auto680):03004 FCC 'SPAC' ; 'SPACE'
+1A54 C5 (fig-forth-auto680):03005 FCB $C5
+1A55 1A3D (fig-forth-auto680):03006 FDB ROT-6
+1A57 17B9185E1542 (fig-forth-auto680):03007 SPACE FDB DOCOL,BL,EMIT
+1A5D 1667 (fig-forth-auto680):03008 FDB SEMIS
+ (fig-forth-auto680):03009 *
+ (fig-forth-auto680):03010 * ======>> 95 <<
+ (fig-forth-auto680):03011 * ( n0 n1 --- min(n0,n1) )
+ (fig-forth-auto680):03012 * Leave the minimum of the top two integers.
+ (fig-forth-auto680):03013 * Being too greedy here, but, whatever.
+1A5F 83 (fig-forth-auto680):03014 FCB $83
+1A60 4D49 (fig-forth-auto680):03015 FCC 'MI' ; 'MIN'
+1A62 CE (fig-forth-auto680):03016 FCB $CE
+1A63 1A4F (fig-forth-auto680):03017 FDB SPACE-8
+1A65 1A67 (fig-forth-auto680):03018 MIN FDB *+NATWID
+1A67 3706 (fig-forth-auto680):03019 PULU D
+1A69 10A3C4 (fig-forth-auto680):03020 CMPD ,U
+1A6C 2F02 (fig-forth-auto680):03021 BLE MINX
+1A6E EDC4 (fig-forth-auto680):03022 STD ,U
+1A70 39 (fig-forth-auto680):03023 MINX RTS
+ (fig-forth-auto680):03024 * MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
+ (fig-forth-auto680):03025 * FDB MIN2-*-NATWID
+ (fig-forth-auto680):03026 * FDB SWAP
+ (fig-forth-auto680):03027 * MIN2 FDB DROP
+ (fig-forth-auto680):03028 * FDB SEMIS
+ (fig-forth-auto680):03029 *
+ (fig-forth-auto680):03030 * ======>> 96 <<
+ (fig-forth-auto680):03031 * ( n0 n1 --- max(n0,n1) )
+ (fig-forth-auto680):03032 * Leave the maximum of the top two integers.
+ (fig-forth-auto680):03033 * Really should leave this as in the model.
+1A71 83 (fig-forth-auto680):03034 FCB $83
+1A72 4D41 (fig-forth-auto680):03035 FCC 'MA' ; 'MAX'
+1A74 D8 (fig-forth-auto680):03036 FCB $D8
+1A75 1A5F (fig-forth-auto680):03037 FDB MIN-6
+1A77 1A79 (fig-forth-auto680):03038 MAX FDB *+NATWID
+1A79 3706 (fig-forth-auto680):03039 PULU D
+1A7B 10A3C4 (fig-forth-auto680):03040 CMPD ,U
+1A7E 2F02 (fig-forth-auto680):03041 BLE MAXX
+1A80 EDC4 (fig-forth-auto680):03042 STD ,U
+1A82 39 (fig-forth-auto680):03043 MAXX RTS
+ (fig-forth-auto680):03044 * MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
+ (fig-forth-auto680):03045 * FDB MAX2-*-NATWID
+ (fig-forth-auto680):03046 * FDB SWAP
+ (fig-forth-auto680):03047 * MAX2 FDB DROP
+ (fig-forth-auto680):03048 * FDB SEMIS
+ (fig-forth-auto680):03049 *
+ (fig-forth-auto680):03050 * ======>> 97 <<
+ (fig-forth-auto680):03051 * ( 0 --- 0 )
+ (fig-forth-auto680):03052 * ( n --- n n )
+ (fig-forth-auto680):03053 * DUP if non-zero.
+1A83 84 (fig-forth-auto680):03054 FCB $84
+1A84 2D4455 (fig-forth-auto680):03055 FCC '-DU' ; '-DUP'
+1A87 D0 (fig-forth-auto680):03056 FCB $D0
+1A88 1A71 (fig-forth-auto680):03057 FDB MAX-6
+1A8A 1A8C (fig-forth-auto680):03058 DDUP FDB *+NATWID
+1A8C ECC4 (fig-forth-auto680):03059 LDD ,U
+1A8E 2702 (fig-forth-auto680):03060 BEQ DDUPX
+1A90 3606 (fig-forth-auto680):03061 PSHU D
+1A92 39 (fig-forth-auto680):03062 DDUPX RTS
+ (fig-forth-auto680):03063 * DDUP FDB DOCOL,DUP,ZBRAN
+ (fig-forth-auto680):03064 * FDB DDUP2-*-NATWID
+ (fig-forth-auto680):03065 * FDB DUP
+ (fig-forth-auto680):03066 * DDUP2 FDB SEMIS
+ (fig-forth-auto680):03067 *
+ (fig-forth-auto680):03068 * ######>> screen 39 <<
+ (fig-forth-auto680):03069 * ======>> 98.1 <<
+ (fig-forth-auto680):03070 * Supplemental:
+ (fig-forth-auto680):03071 * ( n<0 --- -1 )
+ (fig-forth-auto680):03072 * ( n>=~ --- 1 )
+ (fig-forth-auto680):03073 * Change top integer to its sign.
+1A93 86 (fig-forth-auto680):03074 FCB $86
+1A94 5349474E55 (fig-forth-auto680):03075 FCC 'SIGNU' ; 'SIGNUM'
+1A99 CD (fig-forth-auto680):03076 FCB $CD
+1A9A 1A83 (fig-forth-auto680):03077 FDB DDUP-7
+1A9C 1A9E (fig-forth-auto680):03078 SIGNUM FDB *+NATWID
+1A9E C601 (fig-forth-auto680):03079 SIGNUE LDB #1
+1AA0 A6C4 (fig-forth-auto680):03080 LDA ,U
+1AA2 2A01 (fig-forth-auto680):03081 BPL SIGNUP
+1AA4 50 (fig-forth-auto680):03082 NEGB
+1AA5 1D (fig-forth-auto680):03083 SIGNUP SEX ; Couldn't they have called SignEXtend EXT instead?
+1AA6 EDC4 (fig-forth-auto680):03084 STD ,U ; Am I too much of a prude?
+1AA8 39 (fig-forth-auto680):03085 RTS
+ (fig-forth-auto680):03086 * 6800 model version should be something like this:
+ (fig-forth-auto680):03087 * LDB #1
+ (fig-forth-auto680):03088 * CLRA
+ (fig-forth-auto680):03089 * TSX
+ (fig-forth-auto680):03090 * TST ,X
+ (fig-forth-auto680):03091 * BPL SIGNUP
+ (fig-forth-auto680):03092 * NEGB
+ (fig-forth-auto680):03093 * COMA
+ (fig-forth-auto680):03094 * SIGNUP JMP STABX
+ (fig-forth-auto680):03095 *
+ (fig-forth-auto680):03096 * ======>> 98 <<
+ (fig-forth-auto680):03097 * ( adr1 direction --- adr2 )
+ (fig-forth-auto680):03098 * TRAVERSE the symbol name.
+ (fig-forth-auto680):03099 * If direction is 1, find the end.
+ (fig-forth-auto680):03100 * If direction is -1, find the beginning.
+1AA9 88 (fig-forth-auto680):03101 FCB $88
+1AAA 54524156455253 (fig-forth-auto680):03102 FCC 'TRAVERS' ; 'TRAVERSE'
+1AB1 C5 (fig-forth-auto680):03103 FCB $C5
+1AB2 1A93 (fig-forth-auto680):03104 FDB SIGNUM-9
+1AB4 1AB6 (fig-forth-auto680):03105 TRAV FDB *+NATWID
+1AB6 8DE6 (fig-forth-auto680):03106 BSR SIGNUE ; Convert negative to -, zero or positive to 1.
+1AB8 ECC1 (fig-forth-auto680):03107 LDD ,U++ ; Still in D, but we have to pop it anyway.
+1ABA AEC4 (fig-forth-auto680):03108 LDX ,U ; If D is 1 or -1, so is B.
+1ABC 867F (fig-forth-auto680):03109 LDA #$7F
+1ABE 3085 (fig-forth-auto680):03110 TRAVLP LEAX B,X ; Don't look at the one we start at.
+1AC0 A184 (fig-forth-auto680):03111 CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL.
+1AC2 24FA (fig-forth-auto680):03112 BCC TRAVLP
+1AC4 AFC4 (fig-forth-auto680):03113 TRAVDN STX ,U
+1AC6 39 (fig-forth-auto680):03114 RTS
+ (fig-forth-auto680):03115 * Doing this in 6809 just because it can be done may be getting too greedy.
+ (fig-forth-auto680):03116 * TRAV FDB DOCOL,SWAP
+ (fig-forth-auto680):03117 * TRAV2 FDB OVER,PLUS,LIT8
+ (fig-forth-auto680):03118 * FCB $7F
+ (fig-forth-auto680):03119 * FDB OVER,CAT,LESS,ZBRAN
+ (fig-forth-auto680):03120 * FDB TRAV2-*-NATWID
+ (fig-forth-auto680):03121 * FDB SWAP,DROP
+ (fig-forth-auto680):03122 * FDB SEMIS
+ (fig-forth-auto680):03123 *
+ (fig-forth-auto680):03124 * ======>> 99 <<
+ (fig-forth-auto680):03125 * ( --- symptr )
+ (fig-forth-auto680):03126 * Fetch CURRENT as a per-USER constant.
+1AC7 86 (fig-forth-auto680):03127 FCB $86
+1AC8 4C41544553 (fig-forth-auto680):03128 FCC 'LATES' ; 'LATEST'
+1ACD D4 (fig-forth-auto680):03129 FCB $D4
+1ACE 1AA9 (fig-forth-auto680):03130 FDB TRAV-11
+1AD0 17B9194C17721772 (fig-forth-auto680):03131 LATEST FDB DOCOL,CURENT,AT,AT
+1AD8 1667 (fig-forth-auto680):03132 FDB SEMIS
+ (fig-forth-auto680):03133 * LATEST FDB *+NATWID
+ (fig-forth-auto680):03134 * Getting too greedy:
+ (fig-forth-auto680):03135 * Version 1:
+ (fig-forth-auto680):03136 * TFR DP,A
+ (fig-forth-auto680):03137 * CLRB
+ (fig-forth-auto680):03138 * TFR D,X
+ (fig-forth-auto680):03139 * LDD CURENT+NATWID,PCR
+ (fig-forth-auto680):03140 * LDX [D,X]
+ (fig-forth-auto680):03141 * PSHU X ; Leave the address in X.
+ (fig-forth-auto680):03142 * RTS
+ (fig-forth-auto680):03143 * Version 2:
+ (fig-forth-auto680):03144 * LEAX CURENT,PCR
+ (fig-forth-auto680):03145 * JSR [,X]
+ (fig-forth-auto680):03146 * PULU X
+ (fig-forth-auto680):03147 * LDX [,X]
+ (fig-forth-auto680):03148 * PSHU X
+ (fig-forth-auto680):03149 * RTS
+ (fig-forth-auto680):03150 * Too greedy, too many smantic holes to fall through.
+ (fig-forth-auto680):03151 * If the address at the CFA is made relative,
+ (fig-forth-auto680):03152 * this is part of the code that would be affected
+ (fig-forth-auto680):03153 * if it is in native CPU code.
+ (fig-forth-auto680):03154 *
+ (fig-forth-auto680):03155 * ======>> 100 <<
+ (fig-forth-auto680):03156 * Wanted to do these as INCREMENTERs,
+ (fig-forth-auto680):03157 * but I need to stick with the model as much as possible,
+ (fig-forth-auto680):03158 * (mostly, LOL) adding code only to make the model more clear.
+ (fig-forth-auto680):03159 * ( pfa --- lfa )
+ (fig-forth-auto680):03160 * Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
+1ADA 83 (fig-forth-auto680):03161 FCB $83
+1ADB 4C46 (fig-forth-auto680):03162 FCC 'LF' ; 'LFA'
+1ADD C1 (fig-forth-auto680):03163 FCB $C1
+1ADE 1AC7 (fig-forth-auto680):03164 FDB LATEST-9
+1AE0 17B913A7 (fig-forth-auto680):03165 LFA FDB DOCOL,LIT8
+ (fig-forth-auto680):03166 * FCB 4
+1AE4 04 (fig-forth-auto680):03167 FCB 2*NATWID
+1AE5 1A04 (fig-forth-auto680):03168 FDB SUB
+1AE7 1667 (fig-forth-auto680):03169 FDB SEMIS
+ (fig-forth-auto680):03170 *
+ (fig-forth-auto680):03171 * ======>> 101 <<
+ (fig-forth-auto680):03172 * ( pfa --- cfa )
+ (fig-forth-auto680):03173 * Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
+1AE9 83 (fig-forth-auto680):03174 FCB $83
+1AEA 4346 (fig-forth-auto680):03175 FCC 'CF' ; 'CFA'
+1AEC C1 (fig-forth-auto680):03176 FCB $C1
+1AED 1ADA (fig-forth-auto680):03177 FDB LFA-6
+ (fig-forth-auto680):03178 * CFA FDB DOCOL,TWO,SUB
+1AEF 17B917F71A04 (fig-forth-auto680):03179 CFA FDB DOCOL,NATWC,SUB
+1AF5 1667 (fig-forth-auto680):03180 FDB SEMIS
+ (fig-forth-auto680):03181 *
+ (fig-forth-auto680):03182 * ======>> 102 <<
+ (fig-forth-auto680):03183 * ( pfa --- nfa )
+ (fig-forth-auto680):03184 * Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
+1AF7 83 (fig-forth-auto680):03185 FCB $83
+1AF8 4E46 (fig-forth-auto680):03186 FCC 'NF' ; 'NFA'
+1AFA C1 (fig-forth-auto680):03187 FCB $C1
+1AFB 1AE9 (fig-forth-auto680):03188 FDB CFA-6
+1AFD 17B913A7 (fig-forth-auto680):03189 NFA FDB DOCOL,LIT8
+ (fig-forth-auto680):03190 * FCB 5
+1B01 05 (fig-forth-auto680):03191 FCB NATWID*2+1
+1B02 1A04184516EF1AB4 (fig-forth-auto680):03192 FDB SUB,ONE,MINUS,TRAV
+1B0A 1667 (fig-forth-auto680):03193 FDB SEMIS
+ (fig-forth-auto680):03194 *
+ (fig-forth-auto680):03195 * ======>> 103 <<
+ (fig-forth-auto680):03196 * ( nfa --- pfa )
+ (fig-forth-auto680):03197 * Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
+1B0C 83 (fig-forth-auto680):03198 FCB $83
+1B0D 5046 (fig-forth-auto680):03199 FCC 'PF' ; 'PFA'
+1B0F C1 (fig-forth-auto680):03200 FCB $C1
+1B10 1AF7 (fig-forth-auto680):03201 FDB NFA-6
+1B12 17B918451AB413A7 (fig-forth-auto680):03202 PFA FDB DOCOL,ONE,TRAV,LIT8
+ (fig-forth-auto680):03203 * FCB 5
+1B1A 05 (fig-forth-auto680):03204 FCB NATWID*2+1
+1B1B 16C6 (fig-forth-auto680):03205 FDB PLUS
+1B1D 1667 (fig-forth-auto680):03206 FDB SEMIS
+ (fig-forth-auto680):03207 *
+ (fig-forth-auto680):03208 * ######>> screen 40 <<
+ (fig-forth-auto680):03209 * ======>> 104 <<
+ (fig-forth-auto680):03210 * ( --- )
+ (fig-forth-auto680):03211 * Save the parameter stack pointer in CSP for compiler checks.
+1B1F 84 (fig-forth-auto680):03212 FCB $84
+1B20 214353 (fig-forth-auto680):03213 FCC '!CS' ; '!CSP'
+1B23 D0 (fig-forth-auto680):03214 FCB $D0
+1B24 1B0C (fig-forth-auto680):03215 FDB PFA-6
+1B26 17B916401981178A (fig-forth-auto680):03216 SCSP FDB DOCOL,SPAT,CSP,STORE
+1B2E 1667 (fig-forth-auto680):03217 FDB SEMIS
+ (fig-forth-auto680):03218 *
+ (fig-forth-auto680):03219 * ======>> 105 <<
+ (fig-forth-auto680):03220 * ( 0 n --- ) ( *** )
+ (fig-forth-auto680):03221 * ( true n --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03222 * If flag is false, do nothing.
+ (fig-forth-auto680):03223 * If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
+ (fig-forth-auto680):03224 * Leaves cursor position (IN)
+ (fig-forth-auto680):03225 * and currently loading block number (BLK) on stack, for analysis.
+ (fig-forth-auto680):03226 *
+ (fig-forth-auto680):03227 * This one is too important to be high-level Forth codes.
+ (fig-forth-auto680):03228 * When we have an error, we want to disturb as little as possible.
+ (fig-forth-auto680):03229 * But fixing that cascades through ERROR and MESSAGE
+ (fig-forth-auto680):03230 * into the disk block system.
+ (fig-forth-auto680):03231 * And we aren't ready for that yet.
+1B30 86 (fig-forth-auto680):03232 FCB $86
+1B31 3F4552524F (fig-forth-auto680):03233 FCC '?ERRO' ; '?ERROR'
+1B36 D2 (fig-forth-auto680):03234 FCB $D2
+1B37 1B1F (fig-forth-auto680):03235 FDB SCSP-7
+ (fig-forth-auto680):03236 * QERR FDB *+NATWID
+ (fig-forth-auto680):03237 * LDD NATWID,U
+ (fig-forth-auto680):03238 * BNE QERROR
+ (fig-forth-auto680):03239 * LEAU 2*NATWID,U
+ (fig-forth-auto680):03240 * RTS
+ (fig-forth-auto680):03241 ** this doesn't work anyway: QERROR LBR ERROR
+1B39 17B917361409 (fig-forth-auto680):03242 QERR FDB DOCOL,SWAP,ZBRAN
+1B3F 0006 (fig-forth-auto680):03243 FDB QERR2-*-NATWID
+1B41 1FE713FA (fig-forth-auto680):03244 FDB ERROR,BRAN
+1B45 0002 (fig-forth-auto680):03245 FDB QERR3-*-NATWID
+1B47 172A (fig-forth-auto680):03246 QERR2 FDB DROP
+1B49 1667 (fig-forth-auto680):03247 QERR3 FDB SEMIS
+ (fig-forth-auto680):03248 *
+ (fig-forth-auto680):03249 * ======>> 106 <<
+ (fig-forth-auto680):03250 * STATE is compiling:
+ (fig-forth-auto680):03251 * ( --- ) ( *** )
+ (fig-forth-auto680):03252 * STATE is compiling:
+ (fig-forth-auto680):03253 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03254 * ERROR if not compiling.
+1B4B 85 (fig-forth-auto680):03255 FCB $85
+1B4C 3F434F4D (fig-forth-auto680):03256 FCC '?COM' ; '?COMP'
+1B50 D0 (fig-forth-auto680):03257 FCB $D0
+1B51 1B30 (fig-forth-auto680):03258 FDB QERR-9
+1B53 17B91958177216A3 (fig-forth-auto680):03259 QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8
+ 13A7
+1B5D 11 (fig-forth-auto680):03260 FCB $11
+1B5E 1B39 (fig-forth-auto680):03261 FDB QERR
+1B60 1667 (fig-forth-auto680):03262 FDB SEMIS
+ (fig-forth-auto680):03263 *
+ (fig-forth-auto680):03264 * ======>> 107 <<
+ (fig-forth-auto680):03265 * STATE is executing:
+ (fig-forth-auto680):03266 * ( --- ) ( *** )
+ (fig-forth-auto680):03267 * STATE is executing:
+ (fig-forth-auto680):03268 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03269 * ERROR if not executing.
+1B62 85 (fig-forth-auto680):03270 FCB $85
+1B63 3F455845 (fig-forth-auto680):03271 FCC '?EXE' ; '?EXEC'
+1B67 C3 (fig-forth-auto680):03272 FCB $C3
+1B68 1B4B (fig-forth-auto680):03273 FDB QCOMP-8
+1B6A 17B91958177213A7 (fig-forth-auto680):03274 QEXEC FDB DOCOL,STATE,AT,LIT8
+1B72 12 (fig-forth-auto680):03275 FCB $12
+1B73 1B39 (fig-forth-auto680):03276 FDB QERR
+1B75 1667 (fig-forth-auto680):03277 FDB SEMIS
+ (fig-forth-auto680):03278 *
+ (fig-forth-auto680):03279 * ======>> 108 <<
+ (fig-forth-auto680):03280 * ( n1 n1 --- ) ( *** )
+ (fig-forth-auto680):03281 * ( n1 n2 --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03282 * ERROR if top two are unequal.
+ (fig-forth-auto680):03283 * MESSAGE says compiled conditionals do not match.
+1B77 86 (fig-forth-auto680):03284 FCB $86
+1B78 3F50414952 (fig-forth-auto680):03285 FCC '?PAIR' ; '?PAIRS'
+1B7D D3 (fig-forth-auto680):03286 FCB $D3
+1B7E 1B62 (fig-forth-auto680):03287 FDB QEXEC-8
+1B80 17B91A0413A7 (fig-forth-auto680):03288 QPAIRS FDB DOCOL,SUB,LIT8
+1B86 13 (fig-forth-auto680):03289 FCB $13
+1B87 1B39 (fig-forth-auto680):03290 FDB QERR
+1B89 1667 (fig-forth-auto680):03291 FDB SEMIS
+ (fig-forth-auto680):03292 *
+ (fig-forth-auto680):03293 * ======>> 109 <<
+ (fig-forth-auto680):03294 * CSP and parameter stack are balanced (equal):
+ (fig-forth-auto680):03295 * ( --- ) ( *** )
+ (fig-forth-auto680):03296 * CSP and parameter stack are not balanced (unequal):
+ (fig-forth-auto680):03297 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03298 * ERROR if return/control stack is not at same level as last !CSP.
+ (fig-forth-auto680):03299 * Usually indicates that a definition has been left incomplete.
+1B8B 84 (fig-forth-auto680):03300 FCB $84
+1B8C 3F4353 (fig-forth-auto680):03301 FCC '?CS' ; '?CSP'
+1B8F D0 (fig-forth-auto680):03302 FCB $D0
+1B90 1B77 (fig-forth-auto680):03303 FDB QPAIRS-9
+1B92 17B9164019811772 (fig-forth-auto680):03304 QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8
+ 1A0413A7
+1B9E 14 (fig-forth-auto680):03305 FCB $14
+1B9F 1B39 (fig-forth-auto680):03306 FDB QERR
+1BA1 1667 (fig-forth-auto680):03307 FDB SEMIS
+ (fig-forth-auto680):03308 *
+ (fig-forth-auto680):03309 * ======>> 110 <<
+ (fig-forth-auto680):03310 * Active BLK input:
+ (fig-forth-auto680):03311 * ( --- ) ( *** )
+ (fig-forth-auto680):03312 * No active BLK input:
+ (fig-forth-auto680):03313 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03314 * ERROR if not loading, i. e., if BLK is zero.
+1BA3 88 (fig-forth-auto680):03315 FCB $88
+1BA4 3F4C4F4144494E (fig-forth-auto680):03316 FCC '?LOADIN' ; '?LOADING'
+1BAB C7 (fig-forth-auto680):03317 FCB $C7
+1BAC 1B8B (fig-forth-auto680):03318 FDB QCSP-7
+1BAE 17B91906177216A3 (fig-forth-auto680):03319 QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8
+ 13A7
+1BB8 16 (fig-forth-auto680):03320 FCB $16
+1BB9 1B39 (fig-forth-auto680):03321 FDB QERR
+1BBB 1667 (fig-forth-auto680):03322 FDB SEMIS
+ (fig-forth-auto680):03323 *
+ (fig-forth-auto680):03324 * ######>> screen 41 <<
+ (fig-forth-auto680):03325 * ======>> 111 <<
+ (fig-forth-auto680):03326 * ( --- )
+ (fig-forth-auto680):03327 * Compile an in-line literal value from the instruction stream.
+1BBD 87 (fig-forth-auto680):03328 FCB $87
+1BBE 434F4D50494C (fig-forth-auto680):03329 FCC 'COMPIL' ; 'COMPILE'
+1BC4 C5 (fig-forth-auto680):03330 FCB $C5
+1BC5 1BA3 (fig-forth-auto680):03331 FDB QLOAD-11
+ (fig-forth-auto680):03332 * COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
+ (fig-forth-auto680):03333 * COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
+1BC7 17B91B5316901745 (fig-forth-auto680):03334 COMPIL FDB DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
+ 18021681177219E3
+1BD7 1667 (fig-forth-auto680):03335 FDB SEMIS
+ (fig-forth-auto680):03336 *
+ (fig-forth-auto680):03337 * ======>> 112 <<
+ (fig-forth-auto680):03338 * ( --- ) P
+ (fig-forth-auto680):03339 * Clear the compile state bit(s) (shift to interpret).
+1BD9 C1 (fig-forth-auto680):03340 FCB $C1 [ immediate
+1BDA DB (fig-forth-auto680):03341 FCB $DB
+1BDB 1BBD (fig-forth-auto680):03342 FDB COMPIL-10
+1BDD 17B9183D1958178A (fig-forth-auto680):03343 LBRAK FDB DOCOL,ZERO,STATE,STORE
+1BE5 1667 (fig-forth-auto680):03344 FDB SEMIS
+ (fig-forth-auto680):03345 *
+ (fig-forth-auto680):03346 * ======>> 113 <<
+ (fig-forth-auto680):03347 *
+ 00C0 (fig-forth-auto680):03348 STCOMP EQU $C0
+ (fig-forth-auto680):03349 * ( --- )
+ (fig-forth-auto680):03350 * Set the compile state bit(s) (shift to compile).
+1BE7 81 (fig-forth-auto680):03351 FCB $81 ]
+1BE8 DD (fig-forth-auto680):03352 FCB $DD
+1BE9 1BD9 (fig-forth-auto680):03353 FDB LBRAK-4
+1BEB 17B913A7 (fig-forth-auto680):03354 RBRAK FDB DOCOL,LIT8
+1BEF C0 (fig-forth-auto680):03355 FCB STCOMP
+1BF0 1958178A (fig-forth-auto680):03356 FDB STATE,STORE
+1BF4 1667 (fig-forth-auto680):03357 FDB SEMIS
+ (fig-forth-auto680):03358 *
+ (fig-forth-auto680):03359 * ======>> 114 <<
+ (fig-forth-auto680):03360 * ( --- )
+ (fig-forth-auto680):03361 * Toggle SMUDGE bit of LATEST definition header,
+ (fig-forth-auto680):03362 * to hide it until defined or reveal it after definition.
+1BF6 86 (fig-forth-auto680):03363 FCB $86
+1BF7 534D554447 (fig-forth-auto680):03364 FCC 'SMUDG' ; 'SMUDGE'
+1BFC C5 (fig-forth-auto680):03365 FCB $C5
+1BFD 1BE7 (fig-forth-auto680):03366 FDB RBRAK-4
+1BFF 17B91AD013A7 (fig-forth-auto680):03367 SMUDGE FDB DOCOL,LATEST,LIT8
+1C05 20 (fig-forth-auto680):03368 FCB FSMUDG
+1C06 1765 (fig-forth-auto680):03369 FDB TOGGLE
+1C08 1667 (fig-forth-auto680):03370 FDB SEMIS
+ (fig-forth-auto680):03371 *
+ (fig-forth-auto680):03372 * ======>> 115 <<
+ (fig-forth-auto680):03373 * ( --- )
+ (fig-forth-auto680):03374 * Set the conversion base to sixteen (b00010000).
+1C0A 83 (fig-forth-auto680):03375 FCB $83
+1C0B 4845 (fig-forth-auto680):03376 FCC 'HE' ; 'HEX'
+1C0D D8 (fig-forth-auto680):03377 FCB $D8
+1C0E 1BF6 (fig-forth-auto680):03378 FDB SMUDGE-9
+1C10 17B9 (fig-forth-auto680):03379 HEX FDB DOCOL
+1C12 13A7 (fig-forth-auto680):03380 FDB LIT8
+1C14 10 (fig-forth-auto680):03381 FCB 16 ; decimal sixteen
+1C15 1963178A (fig-forth-auto680):03382 FDB BASE,STORE
+1C19 1667 (fig-forth-auto680):03383 FDB SEMIS
+ (fig-forth-auto680):03384 *
+ (fig-forth-auto680):03385 * ======>> 116 <<
+ (fig-forth-auto680):03386 * ( --- )
+ (fig-forth-auto680):03387 * Set the conversion base to ten (b00001010).
+1C1B 87 (fig-forth-auto680):03388 FCB $87
+1C1C 444543494D41 (fig-forth-auto680):03389 FCC 'DECIMA' ; 'DECIMAL'
+1C22 CC (fig-forth-auto680):03390 FCB $CC
+1C23 1C0A (fig-forth-auto680):03391 FDB HEX-6
+1C25 17B9 (fig-forth-auto680):03392 DEC FDB DOCOL
+1C27 13A7 (fig-forth-auto680):03393 FDB LIT8
+1C29 0A (fig-forth-auto680):03394 FCB 10 ; decimal ten
+1C2A 1963178A (fig-forth-auto680):03395 FDB BASE,STORE
+1C2E 1667 (fig-forth-auto680):03396 FDB SEMIS
+ (fig-forth-auto680):03397 *
+ (fig-forth-auto680):03398 * ######>> screen 42 <<
+ (fig-forth-auto680):03399 * ======>> 117 <<
+ (fig-forth-auto680):03400 * ( --- ) ( IP *** )
+ (fig-forth-auto680):03401 * Pop the saved IP and use it to
+ (fig-forth-auto680):03402 * compile the latest symbol as a reference to a ;CODE definition;
+ (fig-forth-auto680):03403 * overwrite the code field of the symbol found by LATEST
+ (fig-forth-auto680):03404 * with the address of the low-level characteristic code
+ (fig-forth-auto680):03405 * provided in the defining definition.
+ (fig-forth-auto680):03406 * Look closely at where things return, consider the operation of R> and >R .
+ (fig-forth-auto680):03407 *
+ (fig-forth-auto680):03408 * The machine-level code which follows (;CODE) in the instruction stream
+ (fig-forth-auto680):03409 * is not executed by the defining symbol,
+ (fig-forth-auto680):03410 * but becomes the characteristic of the defined symbol.
+ (fig-forth-auto680):03411 * This is the usual way to generate the characteristics of VARIABLEs,
+ (fig-forth-auto680):03412 * CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
+ (fig-forth-auto680):03413 *
+ (fig-forth-auto680):03414 * Finally, note that, if code shifts from low level back to high
+ (fig-forth-auto680):03415 * (native CPU machine code calling into a list of FORTH codes),
+ (fig-forth-auto680):03416 * the low level code can't just call a high-level definition.
+ (fig-forth-auto680):03417 * Leaf definitions can directly call other leaf definitions,
+ (fig-forth-auto680):03418 * but not non-leafs.
+ (fig-forth-auto680):03419 * It will need an anonymous list, probably embedded in the low-level code,
+ (fig-forth-auto680):03420 * and Y and X will have to be set appropriately before entering the list.
+1C30 87 (fig-forth-auto680):03421 FCB $87
+1C31 283B434F4445 (fig-forth-auto680):03422 FCC '(;CODE' ; '(;CODE)'
+1C37 A9 (fig-forth-auto680):03423 FCB $A9
+1C38 1C1B (fig-forth-auto680):03424 FDB DEC-10
+ (fig-forth-auto680):03425 * PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
+1C3A 17B91690 (fig-forth-auto680):03426 PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+1C3E 1AD01B121AEF178A (fig-forth-auto680):03427 FDB LATEST,PFA,CFA,STORE
+1C46 1667 (fig-forth-auto680):03428 FDB SEMIS
+ (fig-forth-auto680):03429 *
+ (fig-forth-auto680):03430 * ======>> 118 <<
+ (fig-forth-auto680):03431 * ( --- ) P
+ (fig-forth-auto680):03432 * ?CSP to see if there are loose ends in the defining definition
+ (fig-forth-auto680):03433 * before shifting to the assembler,
+ (fig-forth-auto680):03434 * compile (;CODE) in the defining definition's instruction stream,
+ (fig-forth-auto680):03435 * shift to interpreting,
+ (fig-forth-auto680):03436 * make the ASSEMBLER vocabulary current,
+ (fig-forth-auto680):03437 * and !CSP to mark the stack
+ (fig-forth-auto680):03438 * in preparation for assembling low-level code.
+ (fig-forth-auto680):03439 * Note that ;CODE, unlike DOES>, is IMMEDIATE,
+ (fig-forth-auto680):03440 * and compiles (;CODE),
+ (fig-forth-auto680):03441 * which will do the actual work of changing
+ (fig-forth-auto680):03442 * the LATEST definition's characteristic when the defining word runs.
+ (fig-forth-auto680):03443 * Assembly is done by the interpreter, rather than the compiler.
+ (fig-forth-auto680):03444 * I could have avoided the anomalous three-byte code fields by
+ (fig-forth-auto680):03445 *
+ (fig-forth-auto680):03446 * Note that the ASSEMBLER is not part of the model (at this time).
+ (fig-forth-auto680):03447 * That means that, until the assembler is ready,
+ (fig-forth-auto680):03448 * if you want to define low-level words,
+ (fig-forth-auto680):03449 * you have to poke (comma) in hand-assembled stuff.
+ (fig-forth-auto680):03450 *
+1C48 C5 (fig-forth-auto680):03451 FCB $C5 immediate
+1C49 3B434F44 (fig-forth-auto680):03452 FCC ';COD' ; ';CODE'
+1C4D C5 (fig-forth-auto680):03453 FCB $C5
+1C4E 1C30 (fig-forth-auto680):03454 FDB PSCODE-10
+1C50 17B91B921BC71C3A (fig-forth-auto680):03455 SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
+ 1BFF1BDD1D5B
+1C5E 1667 (fig-forth-auto680):03456 FDB SEMIS
+ (fig-forth-auto680):03457 * note: "QSTACK" will be replaced by "ASSEMBLER" later
+ (fig-forth-auto680):03458 *
+ (fig-forth-auto680):03459 * ######>> screen 43 <<
+ (fig-forth-auto680):03460 * ======>> 119 <<
+ (fig-forth-auto680):03461 * ( --- ) C
+ (fig-forth-auto680):03462 * Make the word currently being defined
+ (fig-forth-auto680):03463 * build a header for DOES> definitions.
+ (fig-forth-auto680):03464 * Actually just compiles a CONSTANT zero
+ (fig-forth-auto680):03465 * which can be overwritten later by DOES>.
+ (fig-forth-auto680):03466 * Since the fig models were established, this technique has been deprecated.
+ (fig-forth-auto680):03467 *
+ (fig-forth-auto680):03468 * Note that <BUILDS is not IMMEDIATE,
+ (fig-forth-auto680):03469 * and therefore executes during a definition's run-time,
+ (fig-forth-auto680):03470 * rather than its compile-time.
+ (fig-forth-auto680):03471 * It is not intended to be used directly,
+ (fig-forth-auto680):03472 * but rather so that one definition word can build another.
+ (fig-forth-auto680):03473 * Also, note that nothing particularly special happens
+ (fig-forth-auto680):03474 * in the defining definition until DOES> executes.
+ (fig-forth-auto680):03475 * The name <BUILDS is intended to be a reminder of what is about to occur.
+ (fig-forth-auto680):03476 *
+ (fig-forth-auto680):03477 * <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
+1C60 87 (fig-forth-auto680):03478 FCB $87
+1C61 3C4255494C44 (fig-forth-auto680):03479 FCC '<BUILD' ; '<BUILDS'
+1C67 D3 (fig-forth-auto680):03480 FCB $D3
+1C68 1C48 (fig-forth-auto680):03481 FDB SEMIC-8
+1C6A 17B9183D17DF (fig-forth-auto680):03482 BUILDS FDB DOCOL,ZERO,CON
+1C70 1667 (fig-forth-auto680):03483 FDB SEMIS
+ (fig-forth-auto680):03484 *
+ (fig-forth-auto680):03485 * ======>> 120 <<
+ (fig-forth-auto680):03486 * ( --- ) ( IP *** ) C
+ (fig-forth-auto680):03487 * Define run-time behavior of definitions compiled/defined
+ (fig-forth-auto680):03488 * by a high-level defining definition --
+ (fig-forth-auto680):03489 * the FORTH equivalent of a compiler-compiler.
+ (fig-forth-auto680):03490 * DOES> assumes that the LATEST symbol table entry
+ (fig-forth-auto680):03491 * has at least one word of parameter field,
+ (fig-forth-auto680):03492 * which <BUILDS provides.
+ (fig-forth-auto680):03493 * Note that DOES> is also not IMMEDIATE.
+ (fig-forth-auto680):03494 *
+ (fig-forth-auto680):03495 * When the defining word containing DOES> executes the DOES> icode,
+ (fig-forth-auto680):03496 * it overwrites the LATEST symbol's CFA with jsr <XDOES,
+ (fig-forth-auto680):03497 * overwrites the first word of that symbol's parameter field with its own IP,
+ (fig-forth-auto680):03498 * and pops the previous IP from the return stack.
+ (fig-forth-auto680):03499 * The icodes which follow DOES> in the stream
+ (fig-forth-auto680):03500 * do not execute at the defining word's run-time.
+ (fig-forth-auto680):03501 *
+ (fig-forth-auto680):03502 * Examining XDOES in the virtual machine shows
+ (fig-forth-auto680):03503 * that the defined word will execute those icodes
+ (fig-forth-auto680):03504 * which follow DOES> at its own run-time.
+ (fig-forth-auto680):03505 *
+ (fig-forth-auto680):03506 * The advantage of this kind of behaviour,
+ (fig-forth-auto680):03507 * which you will also note in ;CODE,
+ (fig-forth-auto680):03508 * is that the defined word can contain
+ (fig-forth-auto680):03509 * both operations and data to be operated on.
+ (fig-forth-auto680):03510 * This is how FORTH data objects define their own behavior.
+ (fig-forth-auto680):03511 *
+ (fig-forth-auto680):03512 * Finally, note that the effective parameter field for DOES> definitions
+ (fig-forth-auto680):03513 * starts two NATWID words after the CFA, instead of just one
+ (fig-forth-auto680):03514 * (four bytes instead of two in a sixteen-bit addressing Forth).
+ (fig-forth-auto680):03515 *
+ (fig-forth-auto680):03516 * VOCABULARYs will use this. See definition of word FORTH.
+1C72 85 (fig-forth-auto680):03517 FCB $85
+1C73 444F4553 (fig-forth-auto680):03518 FCC 'DOES' ; 'DOES>'
+1C77 BE (fig-forth-auto680):03519 FCB $BE
+1C78 1C60 (fig-forth-auto680):03520 FDB BUILDS-10
+ (fig-forth-auto680):03521 * DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
+1C7A 17B91690 (fig-forth-auto680):03522 DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+1C7E 1AD01B12178A (fig-forth-auto680):03523 FDB LATEST,PFA,STORE
+1C84 1C3A (fig-forth-auto680):03524 FDB PSCODE
+ (fig-forth-auto680):03525 *
+ (fig-forth-auto680):03526 * ( --- PFA+NATWID ) ( *** IP )
+ (fig-forth-auto680):03527 * Characteristic of a DOES> defined word.
+ (fig-forth-auto680):03528 * The characteristics of DOES> definitions are written in high-level
+ (fig-forth-auto680):03529 * Forth codes rather than native CPU machine level code.
+ (fig-forth-auto680):03530 * The first parameter word points to the high-level characteristic.
+ (fig-forth-auto680):03531 * This routine's job is to push the IP,
+ (fig-forth-auto680):03532 * load the high level characteristic pointer in IP,
+ (fig-forth-auto680):03533 * and leave the address following the characteristic pointer on the stack
+ (fig-forth-auto680):03534 * so the parameter field can be accessed.
+1C86 ECE4 (fig-forth-auto680):03535 DODOES LDD ,S ; Keep the return address.
+1C88 10AFE4 (fig-forth-auto680):03536 STY ,S ; Save/nest the current IP on the return stack.
+1C8B 10AE02 (fig-forth-auto680):03537 LDY NATWID,X ; First parameter is new IP.
+1C8E 3004 (fig-forth-auto680):03538 LEAX 2*NATWID,X ; Address of second parameter.
+1C90 3610 (fig-forth-auto680):03539 PSHU X
+1C92 1F05 (fig-forth-auto680):03540 TFR D,PC ; Synthetic return.
+ (fig-forth-auto680):03541 *
+ (fig-forth-auto680):03542 * From the 6800 model:
+ (fig-forth-auto680):03543 * DODOES LDA IP
+ (fig-forth-auto680):03544 * LDB IP+1
+ (fig-forth-auto680):03545 * LDX RP make room on return stack
+ (fig-forth-auto680):03546 * LEAX -1,X ;
+ (fig-forth-auto680):03547 * LEAX -1,X ;
+ (fig-forth-auto680):03548 * STX RP
+ (fig-forth-auto680):03549 * STA 2,X push return address
+ (fig-forth-auto680):03550 * STB 3,X
+ (fig-forth-auto680):03551 * LDX W get addr of pointer to run-time code
+ (fig-forth-auto680):03552 * LEAX 1,X ;
+ (fig-forth-auto680):03553 * LEAX 1,X ;
+ (fig-forth-auto680):03554 * STX N stash it in scratch area
+ (fig-forth-auto680):03555 * LDX 0,X get new IP
+ (fig-forth-auto680):03556 * STX IP
+ (fig-forth-auto680):03557 * CLRA ; get address of parameter
+ (fig-forth-auto680):03558 * LDB #2
+ (fig-forth-auto680):03559 * ADDB N+1
+ (fig-forth-auto680):03560 * ADCA N
+ (fig-forth-auto680):03561 * PSHS B ; and push it on data stack
+ (fig-forth-auto680):03562 * PSHS A ;
+ (fig-forth-auto680):03563 * JMP NEXT2
+ (fig-forth-auto680):03564 *
+ (fig-forth-auto680):03565 * ######>> screen 44 <<
+ (fig-forth-auto680):03566 * ======>> 121 <<
+ (fig-forth-auto680):03567 * ( strptr --- strptr+1 count )
+ (fig-forth-auto680):03568 * Convert counted string to string and count.
+ (fig-forth-auto680):03569 * (Fetch the byte at strptr, post-increment.)
+1C94 85 (fig-forth-auto680):03570 FCB $85
+1C95 434F554E (fig-forth-auto680):03571 FCC 'COUN' ; 'COUNT'
+1C99 D4 (fig-forth-auto680):03572 FCB $D4
+1C9A 1C72 (fig-forth-auto680):03573 FDB DOES-8
+1C9C 17B9174519AB1736 (fig-forth-auto680):03574 COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
+ 177E
+1CA6 1667 (fig-forth-auto680):03575 FDB SEMIS
+ (fig-forth-auto680):03576 *
+ (fig-forth-auto680):03577 * ======>> 122 <<
+ (fig-forth-auto680):03578 * ( strptr count --- )
+ (fig-forth-auto680):03579 * EMIT count characters at strptr.
+1CA8 84 (fig-forth-auto680):03580 FCB $84
+1CA9 545950 (fig-forth-auto680):03581 FCC 'TYP' ; 'TYPE'
+1CAC C5 (fig-forth-auto680):03582 FCB $C5
+1CAD 1C94 (fig-forth-auto680):03583 FDB COUNT-8
+1CAF 17B91A8A1409 (fig-forth-auto680):03584 TYPE FDB DOCOL,DDUP,ZBRAN
+1CB5 0016 (fig-forth-auto680):03585 FDB TYPE3-*-NATWID
+1CB7 171C16C617361453 (fig-forth-auto680):03586 FDB OVER,PLUS,SWAP,XDO
+1CBF 1465177E1542141D (fig-forth-auto680):03587 TYPE2 FDB I,CAT,EMIT,XLOOP
+1CC7 FFF6 (fig-forth-auto680):03588 FDB TYPE2-*-NATWID
+1CC9 13FA (fig-forth-auto680):03589 FDB BRAN
+1CCB 0002 (fig-forth-auto680):03590 FDB TYPE4-*-NATWID
+1CCD 172A (fig-forth-auto680):03591 TYPE3 FDB DROP
+1CCF 1667 (fig-forth-auto680):03592 TYPE4 FDB SEMIS
+ (fig-forth-auto680):03593 *
+ (fig-forth-auto680):03594 * ======>> 123 <<
+ (fig-forth-auto680):03595 * ( strptr count1 --- strptr count2 )
+ (fig-forth-auto680):03596 * Supress trailing blanks (subtract count of trailing blanks from strptr).
+1CD1 89 (fig-forth-auto680):03597 FCB $89
+1CD2 2D545241494C494E (fig-forth-auto680):03598 FCC '-TRAILIN' ; '-TRAILING'
+1CDA C7 (fig-forth-auto680):03599 FCB $C7
+1CDB 1CA8 (fig-forth-auto680):03600 FDB TYPE-7
+1CDD 17B91745183D1453 (fig-forth-auto680):03601 DTRAIL FDB DOCOL,DUP,ZERO,XDO
+1CE5 171C171C16C61845 (fig-forth-auto680):03602 DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
+ 1A04177E185E
+1CF3 1A041409 (fig-forth-auto680):03603 FDB SUB,ZBRAN
+1CF7 0006 (fig-forth-auto680):03604 FDB DTRAL3-*-NATWID
+1CF9 167513FA (fig-forth-auto680):03605 FDB LEAVE,BRAN
+1CFD 0004 (fig-forth-auto680):03606 FDB DTRAL4-*-NATWID
+1CFF 18451A04 (fig-forth-auto680):03607 DTRAL3 FDB ONE,SUB
+1D03 141D (fig-forth-auto680):03608 DTRAL4 FDB XLOOP
+1D05 FFDE (fig-forth-auto680):03609 FDB DTRAL2-*-NATWID
+1D07 1667 (fig-forth-auto680):03610 FDB SEMIS
+ (fig-forth-auto680):03611 *
+ (fig-forth-auto680):03612 * ======>> 124 <<
+ (fig-forth-auto680):03613 * ( --- )
+ (fig-forth-auto680):03614 * TYPE counted string out of instruction stream (updating IP).
+1D09 84 (fig-forth-auto680):03615 FCB $84
+1D0A 282E22 (fig-forth-auto680):03616 FCC '(."' ; '(.")'
+1D0D A9 (fig-forth-auto680):03617 FCB $A9
+1D0E 1CD1 (fig-forth-auto680):03618 FDB DTRAIL-12
+ (fig-forth-auto680):03619 * PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
+ (fig-forth-auto680):03620 * PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
+1D10 17B9169C1C9C1745 (fig-forth-auto680):03621 PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP
+ 19AB
+1D1A 169016C616811CAF (fig-forth-auto680):03622 FDB FROMR,PLUS,TOR,TYPE
+1D22 1667 (fig-forth-auto680):03623 FDB SEMIS
+ (fig-forth-auto680):03624 *
+ (fig-forth-auto680):03625 * ======>> 125 <<
+ (fig-forth-auto680):03626 * ( --- ) P
+ (fig-forth-auto680):03627 * { ." something-to-be-printed " } typical input
+ (fig-forth-auto680):03628 * Use WORD to parse to trailing quote;
+ (fig-forth-auto680):03629 * if compiling, compile XDOTQ and string parsed,
+ (fig-forth-auto680):03630 * otherwise, TYPE string.
+1D24 C2 (fig-forth-auto680):03631 FCB $C2 immediate
+1D25 2E (fig-forth-auto680):03632 FCC '.' ; '."'
+1D26 A2 (fig-forth-auto680):03633 FCB $A2
+1D27 1D09 (fig-forth-auto680):03634 FDB PDOTQ-7
+1D29 17B9 (fig-forth-auto680):03635 DOTQ FDB DOCOL
+1D2B 13A7 (fig-forth-auto680):03636 FDB LIT8
+1D2D 22 (fig-forth-auto680):03637 FCB $22 ascii quote
+1D2E 195817721409 (fig-forth-auto680):03638 FDB STATE,AT,ZBRAN
+1D34 0012 (fig-forth-auto680):03639 FDB DOTQ1-*-NATWID
+1D36 1BC71D101EBC (fig-forth-auto680):03640 FDB COMPIL,PDOTQ,WORD
+1D3C 19C7177E19AB19D7 (fig-forth-auto680):03641 FDB HERE,CAT,ONEP,ALLOT,BRAN
+ 13FA
+1D46 0008 (fig-forth-auto680):03642 FDB DOTQ2-*-NATWID
+1D48 1EBC19C71C9C1CAF (fig-forth-auto680):03643 DOTQ1 FDB WORD,HERE,COUNT,TYPE
+1D50 1667 (fig-forth-auto680):03644 DOTQ2 FDB SEMIS
+ (fig-forth-auto680):03645 *
+ (fig-forth-auto680):03646 * ######>> screen 45 <<
+ (fig-forth-auto680):03647 * ======>> 126 <<== MACHINE DEPENDENT
+ (fig-forth-auto680):03648 * ( --- ) ( *** )
+ (fig-forth-auto680):03649 * ( --- IN BLK ) ( anything *** nothing )
+ (fig-forth-auto680):03650 * ERROR if parameter stack out of bounds.
+ (fig-forth-auto680):03651 *
+ (fig-forth-auto680):03652 * But checking whether the stack is in bounds or not
+ (fig-forth-auto680):03653 * really should not use the stack.
+ (fig-forth-auto680):03654 * And there really should be a ?RSTACK, as well.
+1D52 86 (fig-forth-auto680):03655 FCB $86
+1D53 3F53544143 (fig-forth-auto680):03656 FCC '?STAC' ; '?STACK'
+1D58 CB (fig-forth-auto680):03657 FCB $CB
+1D59 1D24 (fig-forth-auto680):03658 FDB DOTQ-5
+1D5B 17B913A7 (fig-forth-auto680):03659 QSTACK FDB DOCOL,LIT8
+ (fig-forth-auto680):03660 * FCB $12
+1D5F 12 (fig-forth-auto680):03661 FCB SINIT-ORIG
+ (fig-forth-auto680):03662 * But why use that instead of XSPZER (S0)?
+ (fig-forth-auto680):03663 * Multi-user or multi-tasking would not want that.
+ (fig-forth-auto680):03664 * CMPU <XSPZER
+ (fig-forth-auto680):03665 * FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
+1D60 189C177216401A1D (fig-forth-auto680):03666 FDB PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
+ 1845
+1D6A 1B39 (fig-forth-auto680):03667 FDB QERR
+ (fig-forth-auto680):03668 * prints 'empty stack'
+ (fig-forth-auto680):03669 *
+1D6C 1640 (fig-forth-auto680):03670 QSTAC2 FDB SPAT
+ (fig-forth-auto680):03671 * Here, we compare with a value at least 128
+ (fig-forth-auto680):03672 * higher than dict. ptr. (DICTPT)
+1D6E 19C713A7 (fig-forth-auto680):03673 FDB HERE,LIT8
+1D72 80 (fig-forth-auto680):03674 FCB $80 ; This is a rough check anyway, leave it as is.
+1D73 16C61A1D1409 (fig-forth-auto680):03675 FDB PLUS,LESS,ZBRAN
+1D79 0004 (fig-forth-auto680):03676 FDB QSTAC3-*-NATWID
+1D7B 184D (fig-forth-auto680):03677 FDB TWO ; NOT the NATWID constant!
+1D7D 1B39 (fig-forth-auto680):03678 FDB QERR
+ (fig-forth-auto680):03679 * prints 'full stack'
+ (fig-forth-auto680):03680 *
+1D7F 1667 (fig-forth-auto680):03681 QSTAC3 FDB SEMIS
+ (fig-forth-auto680):03682 *
+ (fig-forth-auto680):03683 * ======>> 127 << this word's function
+ (fig-forth-auto680):03684 * is done by ?STACK in this version
+ (fig-forth-auto680):03685 * FCB $85
+ (fig-forth-auto680):03686 * FCC 4,?FREE
+ (fig-forth-auto680):03687 * FCB $C5
+ (fig-forth-auto680):03688 * FDB QSTACK-9
+ (fig-forth-auto680):03689 *QFREE FDB DOCOL,SPAT,HERE,LIT8
+ (fig-forth-auto680):03690 * FCB $80
+ (fig-forth-auto680):03691 * FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
+ (fig-forth-auto680):03692 *
+ (fig-forth-auto680):03693 * ######>> screen 46 <<
+ (fig-forth-auto680):03694 * ======>> 128 <<
+ (fig-forth-auto680):03695 * ( buffer n --- )
+ (fig-forth-auto680):03696 * ***** Check that this is how it works here:
+ (fig-forth-auto680):03697 * Get up to n-1 characters from the keyboard,
+ (fig-forth-auto680):03698 * storing at buffer and echoing, with backspace editing,
+ (fig-forth-auto680):03699 * quitting when a CR is read.
+ (fig-forth-auto680):03700 * Terminate it with a NUL.
+1D81 86 (fig-forth-auto680):03701 FCB $86
+1D82 4558504543 (fig-forth-auto680):03702 FCC 'EXPEC' ; 'EXPECT'
+1D87 D4 (fig-forth-auto680):03703 FCB $D4
+1D88 1D52 (fig-forth-auto680):03704 FDB QSTACK-9
+1D8A 17B9171C16C6171C (fig-forth-auto680):03705 EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
+ 1453
+ (fig-forth-auto680):03706 * EXPEC2 FDB KEY,DUP,LIT8
+1D94 1556 (fig-forth-auto680):03707 EXPEC2 FDB KEY
+1D96 1399001C13B9 (fig-forth-auto680):03708 FDB LIT,$1C,SHOTOS ; DBG
+1D9C 174513A7 (fig-forth-auto680):03709 FDB DUP,LIT8
+1DA0 0E (fig-forth-auto680):03710 FCB BACKSP-ORIG
+1DA1 189C17721A111409 (fig-forth-auto680):03711 FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing
+1DA9 001D (fig-forth-auto680):03712 FDB EXPEC3-*-NATWID
+1DAB 172A13A7 (fig-forth-auto680):03713 FDB DROP,LIT8
+1DAF 08 (fig-forth-auto680):03714 FCB 8 ( backspace character to emit )
+1DB0 171C14651A111745 (fig-forth-auto680):03715 FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
+ 1690184D1A0416C6
+1DC0 16811A0413FA (fig-forth-auto680):03716 FDB TOR,SUB,BRAN
+1DC6 0025 (fig-forth-auto680):03717 FDB EXPEC6-*-NATWID
+1DC8 174513A7 (fig-forth-auto680):03718 EXPEC3 FDB DUP,LIT8
+1DCC 0D (fig-forth-auto680):03719 FCB $D ( carriage return )
+1DCD 1A111409 (fig-forth-auto680):03720 FDB EQUAL,ZBRAN
+1DD1 000C (fig-forth-auto680):03721 FDB EXPEC4-*-NATWID
+1DD3 1675172A185E183D (fig-forth-auto680):03722 FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
+ 13FA
+1DDD 0002 (fig-forth-auto680):03723 FDB EXPEC5-*-NATWID
+1DDF 1745 (fig-forth-auto680):03724 EXPEC4 FDB DUP
+1DE1 14651798183D1465 (fig-forth-auto680):03725 EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
+ 19AB178A
+1DED 1542141D (fig-forth-auto680):03726 EXPEC6 FDB EMIT,XLOOP
+1DF1 FFA1 (fig-forth-auto680):03727 FDB EXPEC2-*-NATWID
+1DF3 172A (fig-forth-auto680):03728 FDB DROP
+1DF5 1667 (fig-forth-auto680):03729 FDB SEMIS
+ (fig-forth-auto680):03730 *
+ (fig-forth-auto680):03731 * ======>> 129 <<
+ (fig-forth-auto680):03732 * ( --- )
+ (fig-forth-auto680):03733 * EXPECT 128 (TWID) characters to TIB.
+1DF7 85 (fig-forth-auto680):03734 FCB $85
+1DF8 51554552 (fig-forth-auto680):03735 FCC 'QUER' ; 'QUERY'
+1DFC D9 (fig-forth-auto680):03736 FCB $D9
+1DFD 1D81 (fig-forth-auto680):03737 FDB EXPECT-9
+1DFF 17B918BE177219A2 (fig-forth-auto680):03738 QUERY FDB DOCOL,TIB,AT,COLUMS
+1E07 17721D8A183D190F (fig-forth-auto680):03739 FDB AT,EXPECT,ZERO,IN,STORE
+ 178A
+1E11 1667 (fig-forth-auto680):03740 FDB SEMIS
+ (fig-forth-auto680):03741 *
+ (fig-forth-auto680):03742 * ======>> 130 <<
+ (fig-forth-auto680):03743 * ( --- ) P
+ (fig-forth-auto680):03744 * End interpretation of a line or screen, and/or prepare for a new block.
+ (fig-forth-auto680):03745 * Note that the name of this definition is an empty string,
+ (fig-forth-auto680):03746 * so it matches on the terminating NUL in the terminal or block buffer.
+1E13 C1 (fig-forth-auto680):03747 FCB $C1 immediate < carriage return >
+1E14 80 (fig-forth-auto680):03748 FCB $80
+1E15 1DF7 (fig-forth-auto680):03749 FDB QUERY-8
+1E17 17B9190617721409 (fig-forth-auto680):03750 NULL FDB DOCOL,BLK,AT,ZBRAN
+1E1F 0024 (fig-forth-auto680):03751 FDB NULL2-*-NATWID
+1E21 184519061751 (fig-forth-auto680):03752 FDB ONE,BLK,PSTORE
+1E27 183D190F178A1906 (fig-forth-auto680):03753 FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
+ 1772188E2335
+1E35 16A3 (fig-forth-auto680):03754 FDB ZEQU
+ (fig-forth-auto680):03755 * check for end of screen
+1E37 1409 (fig-forth-auto680):03756 FDB ZBRAN
+1E39 0006 (fig-forth-auto680):03757 FDB NULL1-*-NATWID
+1E3B 1B6A1690172A (fig-forth-auto680):03758 FDB QEXEC,FROMR,DROP
+1E41 13FA (fig-forth-auto680):03759 NULL1 FDB BRAN
+1E43 0004 (fig-forth-auto680):03760 FDB NULL3-*-NATWID
+1E45 1690172A (fig-forth-auto680):03761 NULL2 FDB FROMR,DROP
+1E49 1667 (fig-forth-auto680):03762 NULL3 FDB SEMIS
+ (fig-forth-auto680):03763 *
+ (fig-forth-auto680):03764 * ######>> screen 47 <<
+ (fig-forth-auto680):03765 * ======>> 133 <<
+ (fig-forth-auto680):03766 * ( adr n b --- )
+ (fig-forth-auto680):03767 * Fill n bytes at adr with b.
+1E4B 84 (fig-forth-auto680):03768 FCB $84
+1E4C 46494C (fig-forth-auto680):03769 FCC 'FIL' ; 'FILL'
+1E4F CC (fig-forth-auto680):03770 FCB $CC
+1E50 1E13 (fig-forth-auto680):03771 FDB NULL-4
+1E52 17B917361681171C (fig-forth-auto680):03772 FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
+ 1798174519AB
+1E60 169018451A041584 (fig-forth-auto680):03773 FDB FROMR,ONE,SUB,CMOVE
+1E68 1667 (fig-forth-auto680):03774 FDB SEMIS
+ (fig-forth-auto680):03775 *
+ (fig-forth-auto680):03776 * ======>> 134 <<
+ (fig-forth-auto680):03777 * ( adr n --- )
+ (fig-forth-auto680):03778 * Fill n bytes with 0.
+1E6A 85 (fig-forth-auto680):03779 FCB $85
+1E6B 45524153 (fig-forth-auto680):03780 FCC 'ERAS' ; 'ERASE'
+1E6F C5 (fig-forth-auto680):03781 FCB $C5
+1E70 1E4B (fig-forth-auto680):03782 FDB FILL-7
+1E72 17B9183D1E52 (fig-forth-auto680):03783 ERASE FDB DOCOL,ZERO,FILL
+1E78 1667 (fig-forth-auto680):03784 FDB SEMIS
+ (fig-forth-auto680):03785 *
+ (fig-forth-auto680):03786 * ======>> 135 <<
+ (fig-forth-auto680):03787 * ( adr n --- )
+ (fig-forth-auto680):03788 * Fill n bytes with ASCII SPACE.
+1E7A 86 (fig-forth-auto680):03789 FCB $86
+1E7B 424C414E4B (fig-forth-auto680):03790 FCC 'BLANK' ; 'BLANKS'
+1E80 D3 (fig-forth-auto680):03791 FCB $D3
+1E81 1E6A (fig-forth-auto680):03792 FDB ERASE-8
+1E83 17B9185E1E52 (fig-forth-auto680):03793 BLANKS FDB DOCOL,BL,FILL
+1E89 1667 (fig-forth-auto680):03794 FDB SEMIS
+ (fig-forth-auto680):03795 *
+ (fig-forth-auto680):03796 * ======>> 136 <<
+ (fig-forth-auto680):03797 * ( c --- )
+ (fig-forth-auto680):03798 * Format a character at the left of the HLD output buffer.
+1E8B 84 (fig-forth-auto680):03799 FCB $84
+1E8C 484F4C (fig-forth-auto680):03800 FCC 'HOL' ; 'HOLD'
+1E8F C4 (fig-forth-auto680):03801 FCB $C4
+1E90 1E7A (fig-forth-auto680):03802 FDB BLANKS-9
+1E92 17B91399FFFF1994 (fig-forth-auto680):03803 HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
+ 1751199417721798
+1EA2 1667 (fig-forth-auto680):03804 FDB SEMIS
+ (fig-forth-auto680):03805 *
+ (fig-forth-auto680):03806 * ======>> 137 <<
+ (fig-forth-auto680):03807 * ( --- adr )
+ (fig-forth-auto680):03808 * Give the address of the output PAD buffer.
+ (fig-forth-auto680):03809 * PAD points to the end of a 68 byte buffer for numeric conversion.
+1EA4 83 (fig-forth-auto680):03810 FCB $83
+1EA5 5041 (fig-forth-auto680):03811 FCC 'PA' ; 'PAD'
+1EA7 C4 (fig-forth-auto680):03812 FCB $C4
+1EA8 1E8B (fig-forth-auto680):03813 FDB HOLD-7
+1EAA 17B919C713A7 (fig-forth-auto680):03814 PAD FDB DOCOL,HERE,LIT8
+1EB0 44 (fig-forth-auto680):03815 FCB $44
+1EB1 16C6 (fig-forth-auto680):03816 FDB PLUS
+1EB3 1667 (fig-forth-auto680):03817 FDB SEMIS
+ (fig-forth-auto680):03818 *
+ (fig-forth-auto680):03819 * ######>> screen 48 <<
+ (fig-forth-auto680):03820 * ======>> 138 <<
+ (fig-forth-auto680):03821 * ( c --- )
+ (fig-forth-auto680):03822 * Scan a string terminated by the character c or ASCII NUL out of input;
+ (fig-forth-auto680):03823 * store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
+ (fig-forth-auto680):03824 * Leading c are passed over, per ENCLOSE.
+ (fig-forth-auto680):03825 * Scans from BLK, or from TIB if BLK is zero.
+ (fig-forth-auto680):03826 * May overwrite the numeric conversion pad,
+ (fig-forth-auto680):03827 * if really long (length > 31) symbols are scanned.
+1EB5 84 (fig-forth-auto680):03828 FCB $84
+1EB6 574F52 (fig-forth-auto680):03829 FCC 'WOR' ; 'WORD'
+1EB9 C4 (fig-forth-auto680):03830 FCB $C4
+1EBA 1EA4 (fig-forth-auto680):03831 FDB PAD-6
+1EBC 17B9190617721409 (fig-forth-auto680):03832 WORD FDB DOCOL,BLK,AT,ZBRAN
+1EC4 000A (fig-forth-auto680):03833 FDB WORD2-*-NATWID
+1EC6 19061772249213FA (fig-forth-auto680):03834 FDB BLK,AT,BLOCK,BRAN
+1ECE 0004 (fig-forth-auto680):03835 FDB WORD3-*-NATWID
+1ED0 18BE1772 (fig-forth-auto680):03836 WORD2 FDB TIB,AT
+1ED4 190F177216C61736 (fig-forth-auto680):03837 WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
+ 14FD19C713A7
+1EE2 22 (fig-forth-auto680):03838 FCB 34
+1EE3 1E83190F1751171C (fig-forth-auto680):03839 FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
+ 1A041681169C19C7
+1EF3 179816C619C719AB (fig-forth-auto680):03840 FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
+ 16901584
+1EFF 1667 (fig-forth-auto680):03841 FDB SEMIS
+ (fig-forth-auto680):03842 *
+ (fig-forth-auto680):03843 * ######>> screen 49 <<
+ (fig-forth-auto680):03844 * ======>> 139 <<
+ (fig-forth-auto680):03845 * ( d1 string --- d2 adr )
+ (fig-forth-auto680):03846 * Convert the text at string into a number, accumulating the result into d1,
+ (fig-forth-auto680):03847 * leaving adr pointing to the first character not converted.
+ (fig-forth-auto680):03848 * If DPL is non-negative at entry,
+ (fig-forth-auto680):03849 * accumulates the number of characters converted into DPL.
+1F01 88 (fig-forth-auto680):03850 FCB $88
+1F02 284E554D424552 (fig-forth-auto680):03851 FCC '(NUMBER' ; '(NUMBER)'
+1F09 A9 (fig-forth-auto680):03852 FCB $A9
+1F0A 1EB5 (fig-forth-auto680):03853 FDB WORD-7
+1F0C 17B9 (fig-forth-auto680):03854 PNUMB FDB DOCOL
+1F0E 19AB17451681177E (fig-forth-auto680):03855 PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
+ 1963177214741409
+1F1E 002A (fig-forth-auto680):03856 FDB PNUMB4-*-NATWID
+1F20 17361963177215A5 (fig-forth-auto680):03857 FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
+ 172A1A431963
+1F2E 177215A516D4196D (fig-forth-auto680):03858 FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
+ 177219AB1409
+1F3C 0006 (fig-forth-auto680):03859 FDB PNUMB3-*-NATWID
+1F3E 1845196D1751 (fig-forth-auto680):03860 FDB ONE,DPL,PSTORE
+1F44 169013FA (fig-forth-auto680):03861 PNUMB3 FDB FROMR,BRAN
+1F48 FFC4 (fig-forth-auto680):03862 FDB PNUMB2-*-NATWID
+1F4A 1690 (fig-forth-auto680):03863 PNUMB4 FDB FROMR
+1F4C 1667 (fig-forth-auto680):03864 FDB SEMIS
+ (fig-forth-auto680):03865 *
+ (fig-forth-auto680):03866 * ======>> 140 <<
+ (fig-forth-auto680):03867 * ( ctstr --- d )
+ (fig-forth-auto680):03868 * Convert text at ctstr to a double integer,
+ (fig-forth-auto680):03869 * taking the 0 ERROR if the conversion is not valid.
+ (fig-forth-auto680):03870 * If a decimal point is present,
+ (fig-forth-auto680):03871 * accumulate the count of digits to the decimal point's right into DPL
+ (fig-forth-auto680):03872 * (negative DPL at exit indicates single precision).
+ (fig-forth-auto680):03873 * ctstr is a counted string
+ (fig-forth-auto680):03874 * -- the first byte at ctstr is the length of the string,
+ (fig-forth-auto680):03875 * but NUMBER ignores the count and expects a NUL terminator instead.
+1F4E 86 (fig-forth-auto680):03876 FCB $86
+1F4F 4E554D4245 (fig-forth-auto680):03877 FCC 'NUMBE' ; 'NUMBER'
+1F54 D2 (fig-forth-auto680):03878 FCB $D2
+1F55 1F01 (fig-forth-auto680):03879 FDB PNUMB-11
+1F57 17B9183D183D1A43 (fig-forth-auto680):03880 NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,LIT8
+ 174519AB177E13A7
+1F67 2D (fig-forth-auto680):03881 FCC "-" minus sign
+1F68 1A111745168116C6 (fig-forth-auto680):03882 FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
+ 1399FFFF
+1F74 196D178A1F0C1745 (fig-forth-auto680):03883 NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
+ 177E185E1A04
+1F82 1409 (fig-forth-auto680):03884 FDB ZBRAN
+1F84 0013 (fig-forth-auto680):03885 FDB NUMB2-*-NATWID
+1F86 1745177E13A7 (fig-forth-auto680):03886 FDB DUP,CAT,LIT8
+1F8C 2E (fig-forth-auto680):03887 FCC "."
+1F8D 1A04183D1B39183D (fig-forth-auto680):03888 FDB SUB,ZERO,QERR,ZERO,BRAN
+ 13FA
+1F97 FFDB (fig-forth-auto680):03889 FDB NUMB1-*-NATWID
+1F99 172A16901409 (fig-forth-auto680):03890 NUMB2 FDB DROP,FROMR,ZBRAN
+1F9F 0002 (fig-forth-auto680):03891 FDB NUMB3-*-NATWID
+1FA1 1702 (fig-forth-auto680):03892 FDB DMINUS
+1FA3 1667 (fig-forth-auto680):03893 NUMB3 FDB SEMIS
+ (fig-forth-auto680):03894 *
+ (fig-forth-auto680):03895 * ======>> 141 <<
+ (fig-forth-auto680):03896 * ( --- locptr length true ) { -FIND name } typical input
+ (fig-forth-auto680):03897 * ( --- false )
+ (fig-forth-auto680):03898 * Parse a word, then FIND,
+ (fig-forth-auto680):03899 * first in the definition vocabulary,
+ (fig-forth-auto680):03900 * then in the CONTEXT (interpretation) vocabulary, if necessary.
+ (fig-forth-auto680):03901 * Returns what (FIND) returns, flag and optional location and length.
+1FA5 85 (fig-forth-auto680):03902 FCB $85
+1FA6 2D46494E (fig-forth-auto680):03903 FCC '-FIN' ; '-FIND'
+1FAA C4 (fig-forth-auto680):03904 FCB $C4
+1FAB 1F4E (fig-forth-auto680):03905 FDB NUMB-9
+1FAD 17B9185E1EBC19C7 (fig-forth-auto680):03906 DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
+ 193E17721772
+1FBB 14AF174516A31409 (fig-forth-auto680):03907 FDB PFIND,DUP,ZEQU,ZBRAN
+1FC3 0008 (fig-forth-auto680):03908 FDB DFIND2-*-NATWID
+1FC5 172A19C71AD014AF (fig-forth-auto680):03909 FDB DROP,HERE,LATEST,PFIND
+1FCD 1667 (fig-forth-auto680):03910 DFIND2 FDB SEMIS
+ (fig-forth-auto680):03911 *
+ (fig-forth-auto680):03912 * ######>> screen 50 <<
+ (fig-forth-auto680):03913 * ======>> 142 <<
+ (fig-forth-auto680):03914 * ( anything --- nothing ) ( anything *** nothing )
+ (fig-forth-auto680):03915 * An indirection for ABORT, for ERROR,
+ (fig-forth-auto680):03916 * which may be modified carefully.
+1FCF 87 (fig-forth-auto680):03917 FCB $87
+1FD0 2841424F5254 (fig-forth-auto680):03918 FCC '(ABORT' ; '(ABORT)'
+1FD6 A9 (fig-forth-auto680):03919 FCB $A9
+1FD7 1FA5 (fig-forth-auto680):03920 FDB DFIND-8
+1FD9 17B92205 (fig-forth-auto680):03921 PABORT FDB DOCOL,ABORT
+1FDD 1667 (fig-forth-auto680):03922 FDB SEMIS
+ (fig-forth-auto680):03923 *
+ (fig-forth-auto680):03924 * ======>> 143 <<
+1FDF 85 (fig-forth-auto680):03925 FCB $85
+1FE0 4552524F (fig-forth-auto680):03926 FCC 'ERRO' ; 'ERROR'
+1FE4 D2 (fig-forth-auto680):03927 FCB $D2
+1FE5 1FCF (fig-forth-auto680):03928 FDB PABORT-10
+ (fig-forth-auto680):03929 * This really should not be high level, according to best practices.
+ (fig-forth-auto680):03930 * But fixing that cascades through MESSAGE,
+ (fig-forth-auto680):03931 * requiring re-architecting the disk block system.
+ (fig-forth-auto680):03932 * First, we need to get this transliteration running.
+1FE7 17B918D8177216B5 (fig-forth-auto680):03933 ERROR FDB DOCOL,WARN,AT,ZLESS
+1FEF 1409 (fig-forth-auto680):03934 FDB ZBRAN
+1FF1 0002 (fig-forth-auto680):03935 FDB ERROR2-*-NATWID
+ (fig-forth-auto680):03936 * note: WARNING is
+ (fig-forth-auto680):03937 * -1 to abort,
+ (fig-forth-auto680):03938 * 0 to print error #
+ (fig-forth-auto680):03939 * and 1 to print error message from disc
+1FF3 1FD9 (fig-forth-auto680):03940 FDB PABORT
+1FF5 19C71C9C1CAF1D10 (fig-forth-auto680):03941 ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
+1FFD 0407 (fig-forth-auto680):03942 FCB 4,7 ( bell )
+1FFF 203F20 (fig-forth-auto680):03943 FCC " ? "
+2002 252B164D190F1772 (fig-forth-auto680):03944 FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
+ 1906177221D7
+2010 1667 (fig-forth-auto680):03945 FDB SEMIS
+ (fig-forth-auto680):03946 *
+ (fig-forth-auto680):03947 * ======>> 144 <<
+ (fig-forth-auto680):03948 * ( n adr --- )
+ (fig-forth-auto680):03949 * Mask byte at adr with n.
+ (fig-forth-auto680):03950 * Not in FIG, don't need it for 8 bit characters after all.
+ (fig-forth-auto680):03951 * FCB $85
+ (fig-forth-auto680):03952 * FCC 'CMAS' ; 'CMASK'
+ (fig-forth-auto680):03953 * FCB $CB ; 'K'
+ (fig-forth-auto680):03954 * FDB ERROR-8
+ (fig-forth-auto680):03955 * CMASK FDB *+NATWID
+ (fig-forth-auto680):03956 * LDX ,U++ ; adr
+ (fig-forth-auto680):03957 * LDD ,U++ ; mask
+ (fig-forth-auto680):03958 * ANDB ,X
+ (fig-forth-auto680):03959 * STB ,X
+ (fig-forth-auto680):03960 * RTS
+ (fig-forth-auto680):03961 *
+ (fig-forth-auto680):03962 * ( adr --- adr )
+ (fig-forth-auto680):03963 * Mask high bit of tail of name in PAD buffer.
+ (fig-forth-auto680):03964 * Not in FIG, need it for 8 bit characters.
+2012 86 (fig-forth-auto680):03965 FCB $86
+2013 4944464C41 (fig-forth-auto680):03966 FCC 'IDFLA' ; 'IDFLAT'
+2018 D4 (fig-forth-auto680):03967 FCB $D4 ; 'T'
+2019 1FDF (fig-forth-auto680):03968 FDB ERROR-8
+201B 201D (fig-forth-auto680):03969 IDFLAT FDB *+NATWID
+201D AEC4 (fig-forth-auto680):03970 LDX ,U
+201F E684 (fig-forth-auto680):03971 LDB ,X ; get the count
+2021 C43F (fig-forth-auto680):03972 ANDB #CTMASK
+2023 A685 (fig-forth-auto680):03973 LDA B,X ; point to the tail
+2025 847F (fig-forth-auto680):03974 ANDA #$7F ; Clear the EndOfName flag bit.
+2027 A785 (fig-forth-auto680):03975 STA B,X
+2029 39 (fig-forth-auto680):03976 RTS
+ (fig-forth-auto680):03977 *
+ (fig-forth-auto680):03978 * ( symptr --- )
+ (fig-forth-auto680):03979 * Print definition's name from its NFA.
+202A 83 (fig-forth-auto680):03980 FCB $83
+202B 4944 (fig-forth-auto680):03981 FCC 'ID' ; 'ID.'
+202D AE (fig-forth-auto680):03982 FCB $AE
+202E 2012 (fig-forth-auto680):03983 FDB IDFLAT-9
+2030 17B91EAA13A7 (fig-forth-auto680):03984 IDDOT FDB DOCOL,PAD,LIT8
+2036 20 (fig-forth-auto680):03985 FCB 32
+2037 13A7 (fig-forth-auto680):03986 FDB LIT8
+2039 5F (fig-forth-auto680):03987 FCB $5F ( underline )
+203A 1E5217451B121AE0 (fig-forth-auto680):03988 FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
+ 171C1A041EAA
+ (fig-forth-auto680):03989 * FDB SWAP,CMOVE,PAD,COUNT,LIT8
+2048 173615841EAA (fig-forth-auto680):03990 FDB SWAP,CMOVE,PAD
+204E 201B (fig-forth-auto680):03991 FDB IDFLAT
+2050 1C9C13A7 (fig-forth-auto680):03992 FDB COUNT,LIT8
+2054 1F (fig-forth-auto680):03993 FCB 31
+2055 160E1CAF1A57 (fig-forth-auto680):03994 FDB AND,TYPE,SPACE
+205B 1667 (fig-forth-auto680):03995 FDB SEMIS
+ (fig-forth-auto680):03996 *
+ (fig-forth-auto680):03997 * ######>> screen 51 <<
+ (fig-forth-auto680):03998 * ======>> 145 <<
+ (fig-forth-auto680):03999 * ( --- ) { CREATE name } input
+ (fig-forth-auto680):04000 * Parse a name (length < 32 characters) and create a header,
+ (fig-forth-auto680):04001 * reporting first duplicate found in either the defining vocabulary
+ (fig-forth-auto680):04002 * or the context (interpreting) vocabulary.
+ (fig-forth-auto680):04003 * Install the header in the defining vocabulary
+ (fig-forth-auto680):04004 * with CFA dangerously pointing to the parameter field.
+ (fig-forth-auto680):04005 * Leave the name SMUDGEd.
+205D 86 (fig-forth-auto680):04006 FCB $86
+205E 4352454154 (fig-forth-auto680):04007 FCC 'CREAT' ; 'CREATE'
+2063 C5 (fig-forth-auto680):04008 FCB $C5
+2064 202A (fig-forth-auto680):04009 FDB IDDOT-6
+2066 17B91FAD1409 (fig-forth-auto680):04010 CREATE FDB DOCOL,DFIND,ZBRAN
+206C 0018 (fig-forth-auto680):04011 FDB CREAT2-*-NATWID
+206E 172A1D10 (fig-forth-auto680):04012 FDB DROP,PDOTQ
+2072 08 (fig-forth-auto680):04013 FCB 8
+2073 07 (fig-forth-auto680):04014 FCB 7 ( bel )
+2074 72656465663A20 (fig-forth-auto680):04015 FCC "redef: "
+207B 1AFD203013A7 (fig-forth-auto680):04016 FDB NFA,IDDOT,LIT8
+2081 04 (fig-forth-auto680):04017 FCB 4
+2082 252B1A57 (fig-forth-auto680):04018 FDB MESS,SPACE
+2086 19C71745177E18CA (fig-forth-auto680):04019 CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
+ 17721A65
+2092 19AB19D7174513A7 (fig-forth-auto680):04020 FDB ONEP,ALLOT,DUP,LIT8
+209A A0 (fig-forth-auto680):04021 FCB ($80|FSMUDG) ; Bracket the name.
+209B 176519C718451A04 (fig-forth-auto680):04022 FDB TOGGLE,HERE,ONE,SUB,LIT8
+ 13A7
+20A5 80 (fig-forth-auto680):04023 FCB $80
+20A6 17651AD019E3194C (fig-forth-auto680):04024 FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
+ 1772178A
+ (fig-forth-auto680):04025 * FDB HERE,TWOP,COMMA
+20B2 19C7180219E3 (fig-forth-auto680):04026 FDB HERE,NATP,COMMA
+20B8 1667 (fig-forth-auto680):04027 FDB SEMIS
+ (fig-forth-auto680):04028 *
+ (fig-forth-auto680):04029 * ######>> screen 52 <<
+ (fig-forth-auto680):04030 * ======>> 146 <<
+ (fig-forth-auto680):04031 * ( --- ) P
+ (fig-forth-auto680):04032 * { [COMPILE] name } typical use
+ (fig-forth-auto680):04033 * -DFIND next WORD and COMPILE it, literally;
+ (fig-forth-auto680):04034 * used to compile immediate definitions into words.
+20BA C9 (fig-forth-auto680):04035 FCB $C9 immediate
+20BB 5B434F4D50494C45 (fig-forth-auto680):04036 FCC '[COMPILE' ; '[COMPILE]'
+20C3 DD (fig-forth-auto680):04037 FCB $DD
+20C4 205D (fig-forth-auto680):04038 FDB CREATE-9
+20C6 17B91FAD16A3183D (fig-forth-auto680):04039 BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
+ 1B39172A1AEF19E3
+20D6 1667 (fig-forth-auto680):04040 FDB SEMIS
+ (fig-forth-auto680):04041 *
+ (fig-forth-auto680):04042 * ======>> 147 <<
+ (fig-forth-auto680):04043 * ( n --- ) if compiling. P
+ (fig-forth-auto680):04044 * ( n --- n ) if interpreting.
+ (fig-forth-auto680):04045 * Compile n as a literal, if compiling.
+20D8 C7 (fig-forth-auto680):04046 FCB $C7 immediate
+20D9 4C4954455241 (fig-forth-auto680):04047 FCC 'LITERA' ; 'LITERAL'
+20DF CC (fig-forth-auto680):04048 FCB $CC
+20E0 20BA (fig-forth-auto680):04049 FDB BCOMP-12
+20E2 17B9195817721409 (fig-forth-auto680):04050 LITER FDB DOCOL,STATE,AT,ZBRAN
+20EA 0006 (fig-forth-auto680):04051 FDB LITER2-*-NATWID
+20EC 1BC7139919E3 (fig-forth-auto680):04052 FDB COMPIL,LIT,COMMA
+20F2 1667 (fig-forth-auto680):04053 LITER2 FDB SEMIS
+ (fig-forth-auto680):04054 *
+ (fig-forth-auto680):04055 * ======>> 148 <<
+ (fig-forth-auto680):04056 * ( d --- ) if compiling. P
+ (fig-forth-auto680):04057 * ( d --- d ) if interpreting.
+ (fig-forth-auto680):04058 * Compile d as a double literal, if compiling.
+20F4 C8 (fig-forth-auto680):04059 FCB $C8 immediate
+20F5 444C4954455241 (fig-forth-auto680):04060 FCC 'DLITERA' ; 'DLITERAL'
+20FC CC (fig-forth-auto680):04061 FCB $CC
+20FD 20D8 (fig-forth-auto680):04062 FDB LITER-10
+20FF 17B9195817721409 (fig-forth-auto680):04063 DLITER FDB DOCOL,STATE,AT,ZBRAN
+2107 0006 (fig-forth-auto680):04064 FDB DLITE2-*-NATWID
+2109 173620E220E2 (fig-forth-auto680):04065 FDB SWAP,LITER,LITER ; Just two literals in the right order.
+210F 1667 (fig-forth-auto680):04066 DLITE2 FDB SEMIS
+ (fig-forth-auto680):04067 *
+ (fig-forth-auto680):04068 * ######>> screen 53 <<
+ (fig-forth-auto680):04069 * ======>> 149 <<
+ (fig-forth-auto680):04070 * ( --- )
+ (fig-forth-auto680):04071 * Interpret or compile, according to STATE.
+ (fig-forth-auto680):04072 * Searches words parsed in dictionary first, via -FIND,
+ (fig-forth-auto680):04073 * then checks for valid NUMBER.
+ (fig-forth-auto680):04074 * Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
+ (fig-forth-auto680):04075 * ERROR checks the stack via ?STACK before returning to its caller.
+2111 89 (fig-forth-auto680):04076 FCB $89
+2112 494E544552505245 (fig-forth-auto680):04077 FCC 'INTERPRE' ; 'INTERPRET'
+211A D4 (fig-forth-auto680):04078 FCB $D4
+211B 20F4 (fig-forth-auto680):04079 FDB DLITER-11
+211D 17B9 (fig-forth-auto680):04080 INTERP FDB DOCOL
+211F 1FAD1409 (fig-forth-auto680):04081 INTER2 FDB DFIND,ZBRAN
+2123 001A (fig-forth-auto680):04082 FDB INTER5-*-NATWID
+2125 195817721A1D (fig-forth-auto680):04083 FDB STATE,AT,LESS
+212B 1409 (fig-forth-auto680):04084 FDB ZBRAN
+212D 0008 (fig-forth-auto680):04085 FDB INTER3-*-NATWID
+212F 1AEF19E313FA (fig-forth-auto680):04086 FDB CFA,COMMA,BRAN
+2135 0004 (fig-forth-auto680):04087 FDB INTER4-*-NATWID
+2137 1AEF13EB (fig-forth-auto680):04088 INTER3 FDB CFA,EXEC
+213B 13FA (fig-forth-auto680):04089 INTER4 FDB BRAN
+213D 0018 (fig-forth-auto680):04090 FDB INTER7-*-NATWID
+213F 19C71F57196D1772 (fig-forth-auto680):04091 INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
+ 19AB1409
+214B 0006 (fig-forth-auto680):04092 FDB INTER6-*-NATWID
+214D 20FF13FA (fig-forth-auto680):04093 FDB DLITER,BRAN
+2151 0004 (fig-forth-auto680):04094 FDB INTER7-*-NATWID
+2153 172A20E2 (fig-forth-auto680):04095 INTER6 FDB DROP,LITER
+2157 1D5B13FA (fig-forth-auto680):04096 INTER7 FDB QSTACK,BRAN
+215B FFC2 (fig-forth-auto680):04097 FDB INTER2-*-NATWID
+ (fig-forth-auto680):04098 * FDB SEMIS never executed
+ (fig-forth-auto680):04099
+ (fig-forth-auto680):04100 *
+ (fig-forth-auto680):04101 * ######>> screen 54 <<
+ (fig-forth-auto680):04102 * ======>> 150 <<
+ (fig-forth-auto680):04103 * ( --- )
+ (fig-forth-auto680):04104 * Toggle precedence bit of LATEST definition header.
+ (fig-forth-auto680):04105 * During compiling, most symbols scanned are compiled.
+ (fig-forth-auto680):04106 * IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
+ (fig-forth-auto680):04107 * but may be compiled via ' (TICK).
+215D 89 (fig-forth-auto680):04108 FCB $89
+215E 494D4D4544494154 (fig-forth-auto680):04109 FCC 'IMMEDIAT' ; 'IMMEDIATE'
+2166 C5 (fig-forth-auto680):04110 FCB $C5
+2167 2111 (fig-forth-auto680):04111 FDB INTERP-12
+2169 17B91AD013A7 (fig-forth-auto680):04112 IMMED FDB DOCOL,LATEST,LIT8
+216F 40 (fig-forth-auto680):04113 FCB FIMMED
+2170 1765 (fig-forth-auto680):04114 FDB TOGGLE
+2172 1667 (fig-forth-auto680):04115 FDB SEMIS
+ (fig-forth-auto680):04116 *
+ (fig-forth-auto680):04117 * ======>> 151 <<
+ (fig-forth-auto680):04118 * ( --- ) { VOCABULARY name } input
+ (fig-forth-auto680):04119 * Create a vocabulary entry with a flag for terminating vocabulary searches.
+ (fig-forth-auto680):04120 * Store the current search context in it for linking.
+ (fig-forth-auto680):04121 * At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
+2174 8A (fig-forth-auto680):04122 FCB $8A
+2175 564F434142554C41 (fig-forth-auto680):04123 FCC 'VOCABULAR' ; 'VOCABULARY'
+ 52
+217E D9 (fig-forth-auto680):04124 FCB $D9
+217F 215D (fig-forth-auto680):04125 FDB IMMED-12
+2181 17B91C6A139981A0 (fig-forth-auto680):04126 VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
+ 19E3194C17721AEF
+2191 19E319C718FC1772 (fig-forth-auto680):04127 FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
+ 19E318FC178A1C7A
+ (fig-forth-auto680):04128 * DOVOC FDB TWOP,CONTXT,STORE
+21A1 1802193E178A (fig-forth-auto680):04129 DOVOC FDB NATP,CONTXT,STORE
+21A7 1667 (fig-forth-auto680):04130 FDB SEMIS
+ (fig-forth-auto680):04131 *
+ (fig-forth-auto680):04132 * ======>> 152 <<
+ (fig-forth-auto680):04133 *
+ (fig-forth-auto680):04134 * Note: FORTH does not go here in the rom-able dictionary,
+ (fig-forth-auto680):04135 * since FORTH is a type of variable.
+ (fig-forth-auto680):04136 *
+ (fig-forth-auto680):04137 * (Should make a proper architecture for this at some point.)
+ (fig-forth-auto680):04138 *
+ (fig-forth-auto680):04139 *
+ (fig-forth-auto680):04140 * ======>> 153 <<
+ (fig-forth-auto680):04141 * ( --- )
+ (fig-forth-auto680):04142 * Makes the current interpretation CONTEXT vocabulary
+ (fig-forth-auto680):04143 * also the CURRENT defining vocabulary.
+21A9 8B (fig-forth-auto680):04144 FCB $8B
+21AA 444546494E495449 (fig-forth-auto680):04145 FCC 'DEFINITION' ; 'DEFINITIONS'
+ 4F4E
+21B4 D3 (fig-forth-auto680):04146 FCB $D3
+21B5 2174 (fig-forth-auto680):04147 FDB VOCAB-13
+21B7 17B9193E1772194C (fig-forth-auto680):04148 DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
+ 178A
+21C1 1667 (fig-forth-auto680):04149 FDB SEMIS
+ (fig-forth-auto680):04150 *
+ (fig-forth-auto680):04151 * ======>> 154 <<
+ (fig-forth-auto680):04152 * ( --- )
+ (fig-forth-auto680):04153 * Parse out a comment and toss it away.
+ (fig-forth-auto680):04154 * Leaves the first 32 characters in WORDPAD, which may or may not be useful.
+21C3 C1 (fig-forth-auto680):04155 FCB $C1 immediate (
+21C4 A8 (fig-forth-auto680):04156 FCB $A8
+21C5 21A9 (fig-forth-auto680):04157 FDB DEFIN-14
+21C7 17B913A7 (fig-forth-auto680):04158 PAREN FDB DOCOL,LIT8
+21CB 29 (fig-forth-auto680):04159 FCC ")"
+21CC 1EBC (fig-forth-auto680):04160 FDB WORD
+21CE 1667 (fig-forth-auto680):04161 FDB SEMIS
+ (fig-forth-auto680):04162 *
+ (fig-forth-auto680):04163 * ######>> screen 55 <<
+ (fig-forth-auto680):04164 * ======>> 155 <<
+ (fig-forth-auto680):04165 * ( anything *** nothing )
+ (fig-forth-auto680):04166 * Clear return stack.
+ (fig-forth-auto680):04167 * Then INTERPRET and, if not compiling, prompt with OK,
+ (fig-forth-auto680):04168 * in infinite loop.
+21D0 84 (fig-forth-auto680):04169 FCB $84
+21D1 515549 (fig-forth-auto680):04170 FCC 'QUI' ; 'QUIT'
+21D4 D4 (fig-forth-auto680):04171 FCB $D4
+21D5 21C3 (fig-forth-auto680):04172 FDB PAREN-4
+21D7 17B9183D1906178A (fig-forth-auto680):04173 QUIT FDB DOCOL,ZERO,BLK,STORE
+21DF 1BDD (fig-forth-auto680):04174 FDB LBRAK
+ (fig-forth-auto680):04175 *
+ (fig-forth-auto680):04176 * Here is the outer interpretter
+ (fig-forth-auto680):04177 * which gets a line of input, does it, prints " OK"
+ (fig-forth-auto680):04178 * then repeats :
+21E1 165815771DFF211D (fig-forth-auto680):04179 QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
+ 1958177216A3
+21EF 1409 (fig-forth-auto680):04180 FDB ZBRAN
+21F1 0006 (fig-forth-auto680):04181 FDB QUIT3-*-NATWID
+21F3 1D10 (fig-forth-auto680):04182 FDB PDOTQ
+21F5 03 (fig-forth-auto680):04183 FCB 3
+21F6 204F4B (fig-forth-auto680):04184 FCC ' OK' ; ' OK'
+21F9 13FA (fig-forth-auto680):04185 QUIT3 FDB BRAN
+21FB FFE4 (fig-forth-auto680):04186 FDB QUIT2-*-NATWID
+ (fig-forth-auto680):04187 * FDB SEMIS ( never executed )
+ (fig-forth-auto680):04188 *
+ (fig-forth-auto680):04189 * ======>> 156 <<
+ (fig-forth-auto680):04190 * ( anything --- nothing ) ( anything *** nothing )
+ (fig-forth-auto680):04191 * Clear parameter stack,
+ (fig-forth-auto680):04192 * set STATE to interpret and BASE to DECIMAL,
+ (fig-forth-auto680):04193 * return to input from terminal,
+ (fig-forth-auto680):04194 * restore DRIVE OFFSET to 0,
+ (fig-forth-auto680):04195 * print out "Forth-68",
+ (fig-forth-auto680):04196 * set interpret and define vocabularies to FORTH,
+ (fig-forth-auto680):04197 * and finally, QUIT.
+ (fig-forth-auto680):04198 * Used to force the system to a known state
+ (fig-forth-auto680):04199 * and return control to the initial INTERPRETer.
+21FD 85 (fig-forth-auto680):04200 FCB $85
+21FE 41424F52 (fig-forth-auto680):04201 FCC 'ABOR' ; 'ABORT'
+2202 D4 (fig-forth-auto680):04202 FCB $D4
+2203 21D0 (fig-forth-auto680):04203 FDB QUIT-7
+2205 17B9164D1C251D5B (fig-forth-auto680):04204 ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
+ 242515771D10
+2213 0A (fig-forth-auto680):04205 FCB 10
+2214 466F7274682D3638 (fig-forth-auto680):04206 FCC "Forth-6809"
+ 3039
+221E 2A9D21B7 (fig-forth-auto680):04207 FDB FORTH,DEFIN
+2222 21D7 (fig-forth-auto680):04208 FDB QUIT
+ (fig-forth-auto680):04209 * FDB SEMIS never executed
+ (fig-forth-auto680):04210 PAGE
+ (fig-forth-auto680):04211 *
+ (fig-forth-auto680):04212 * ######>> screen 56 <<
+ (fig-forth-auto680):04213 * bootstrap code... moves rom contents to ram :
+ (fig-forth-auto680):04214 * ======>> 157 <<
+2224 84 (fig-forth-auto680):04215 FCB $84
+2225 434F4C (fig-forth-auto680):04216 FCC 'COL' ; 'COLD'
+2228 C4 (fig-forth-auto680):04217 FCB $C4
+2229 21FD (fig-forth-auto680):04218 FDB ABORT-8
+222B 222D (fig-forth-auto680):04219 COLD FDB *+NATWID
+ (fig-forth-auto680):04220 * Ultimately, we want position indepence,
+ (fig-forth-auto680):04221 * so I'm using PCR where it seems reasonable.
+222D 10EE8DEFE0 (fig-forth-auto680):04222 CENT LDS SINIT,PCR ; Get a useable return stack, at least.
+2232 867C (fig-forth-auto680):04223 LDA #IUPDP ; This is not relative to PC.
+2234 1F8B (fig-forth-auto680):04224 TFR A,DP ; And a useable direct page, too.
+ 7C (fig-forth-auto680):04225 SETDP IUPDP ; (For good measure.)
+ (fig-forth-auto680):04226 *
+ (fig-forth-auto680):04227 * We'll keep this here for the time being.
+ (fig-forth-auto680):04228 * There are better ways to do this, of course.
+ (fig-forth-auto680):04229 * Re-architect, re-architect.
+2236 308D006A (fig-forth-auto680):04230 LEAX RAM,PCR
+223A 9F28 (fig-forth-auto680):04231 STX <XFENCE ; Borrow this variable for a loop terminator.
+223C 318D0890 (fig-forth-auto680):04232 LEAY REND,PCR ; top of destination
+2240 308D00A3 (fig-forth-auto680):04233 LEAX ERAM,PCR ; top of stuff to move
+2244 A682 (fig-forth-auto680):04234 COLD2 LDA ,-X
+2246 A7A2 (fig-forth-auto680):04235 STA ,-Y ; move TASK & FORTH to ram
+2248 9C28 (fig-forth-auto680):04236 CMPX <XFENCE
+224A 26F8 (fig-forth-auto680):04237 BNE COLD2
+ (fig-forth-auto680):04238 *
+ (fig-forth-auto680):04239 * CENT LDS #REND-1 top of destination
+ (fig-forth-auto680):04240 * LDX #ERAM top of stuff to move
+ (fig-forth-auto680):04241 * COLD2 LEAX -1,X ;
+ (fig-forth-auto680):04242 * LDA 0,X
+ (fig-forth-auto680):04243 * PSHS A ; move TASK & FORTH to ram
+ (fig-forth-auto680):04244 * CMPX #RAM
+ (fig-forth-auto680):04245 * BNE COLD2
+ (fig-forth-auto680):04246 *
+ (fig-forth-auto680):04247 * LDS #XFENCE-1 put stack at a safe place for now
+ (fig-forth-auto680):04248 * But that is taken care of.
+ (fig-forth-auto680):04249 * LDX COLINT
+ (fig-forth-auto680):04250 * STX XCOLUM
+224C AE8DEFD2 (fig-forth-auto680):04251 LDX COLINT,PCR
+2250 9F4C (fig-forth-auto680):04252 STX <XCOLUM
+ (fig-forth-auto680):04253 * LDX DELINT
+ (fig-forth-auto680):04254 * STX XDELAY
+2252 AE8DEFCE (fig-forth-auto680):04255 LDX DELINT,PCR
+2256 9F4A (fig-forth-auto680):04256 STX <XDELAY
+ (fig-forth-auto680):04257 * LDX VOCINT
+ (fig-forth-auto680):04258 * STX XVOCL
+2258 AE8DEFC4 (fig-forth-auto680):04259 LDX VOCINT,PCR
+225C 9F2C (fig-forth-auto680):04260 STX <XVOCL
+ (fig-forth-auto680):04261 * LDX DPINIT
+ (fig-forth-auto680):04262 * STX XDICTP
+225E AE8DEFBC (fig-forth-auto680):04263 LDX DPINIT,PCR
+2262 9F2A (fig-forth-auto680):04264 STX <XDICTP
+ (fig-forth-auto680):04265 * LDX FENCIN
+ (fig-forth-auto680):04266 * STX XFENCE
+2264 AE8DEFB4 (fig-forth-auto680):04267 LDX FENCIN,PCR
+2268 9F28 (fig-forth-auto680):04268 STX <XFENCE
+ (fig-forth-auto680):04269 *
+226A 10EE8DEFA3 (fig-forth-auto680):04270 WENT LDS SINIT,PCR ; Get a useable return stack, at least.
+226F 867C (fig-forth-auto680):04271 LDA #IUPDP ; This is not relative to PC.
+2271 1F8B (fig-forth-auto680):04272 TFR A,DP ; And a useable direct page, too.
+ 7C (fig-forth-auto680):04273 SETDP IUPDP ; (For good measure.)
+ (fig-forth-auto680):04274 *
+2273 308DEF9B (fig-forth-auto680):04275 LEAX SINIT,PCR
+2277 3410 (fig-forth-auto680):04276 PSHS X ; for loop termination
+2279 5F (fig-forth-auto680):04277 CLRB ; Yes, I'm being a little ridiculous. Only a little.
+227A 1F02 (fig-forth-auto680):04278 TFR D,Y
+227C 31A828 (fig-forth-auto680):04279 LEAY XFENCE-UORIG,Y ; top of destination
+227F 308DEF99 (fig-forth-auto680):04280 LEAX FENCIN,PCR ; top of stuff to move
+2283 EC83 (fig-forth-auto680):04281 WARM2 LDD ,--X ; All entries are 16 bit.
+2285 EDA3 (fig-forth-auto680):04282 STD ,--Y
+2287 ACE4 (fig-forth-auto680):04283 CMPX ,S
+2289 26F8 (fig-forth-auto680):04284 BNE WARM2
+228B 3262 (fig-forth-auto680):04285 LEAS 2,S ; But we'll reset the return stack shortly, anyway.
+ (fig-forth-auto680):04286 * WENT LDS #XFENCE-1 top of destination
+ (fig-forth-auto680):04287 * LDX #FENCIN top of stuff to move
+ (fig-forth-auto680):04288 * WARM2 LEAX -1,X ;
+ (fig-forth-auto680):04289 * LDA 0,X
+ (fig-forth-auto680):04290 * PSHS A ;
+ (fig-forth-auto680):04291 * CMPX #SINIT
+ (fig-forth-auto680):04292 * BNE WARM2
+ (fig-forth-auto680):04293 *
+ (fig-forth-auto680):04294 * LDS SINIT
+ (fig-forth-auto680):04295 * S is already there.
+ (fig-forth-auto680):04296 * LDX UPINIT
+ (fig-forth-auto680):04297 * STX UP init user ram pointer
+ (fig-forth-auto680):04298 * UP is already there (DP).
+ (fig-forth-auto680):04299 * LDX #ABORT
+ (fig-forth-auto680):04300 * STX IP
+228D 318DFF76 (fig-forth-auto680):04301 LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
+ (fig-forth-auto680):04302 *
+2291 12 (fig-forth-auto680):04303 NOP Here is a place to jump to special user
+2292 12 (fig-forth-auto680):04304 NOP initializations such as I/0 interrups
+2293 12 (fig-forth-auto680):04305 NOP
+ (fig-forth-auto680):04306 *
+ (fig-forth-auto680):04307 * For systems with TRACE:
+2294 8E0000 (fig-forth-auto680):04308 LDX #00
+ (fig-forth-auto680):04309 * STX TRLIM clear trace mode
+2297 9F0A (fig-forth-auto680):04310 STX <TRLIM clear trace mode (both bytes)
+2299 8E0000 (fig-forth-auto680):04311 LDX #0
+ (fig-forth-auto680):04312 * STX BRKPT clear breakpoint address
+229C 9F0C (fig-forth-auto680):04313 STX <BRKPT clear breakpoint address
+ (fig-forth-auto680):04314 * JMP RPSTOR+2 start the virtual machine running !
+229E 17F3B9 (fig-forth-auto680):04315 LBSR RPSTOR+NATWID start the virtual machine running !
+22A1 16EF84 (fig-forth-auto680):04316 LBRA NEXT ; But we must also give RP! someplace to return.
+ (fig-forth-auto680):04317 * RP! sets up the return stack pointer, then Y references abort.
+ (fig-forth-auto680):04318 *
+ (fig-forth-auto680):04319 * Here is the stuff that gets copied to ram :
+ (fig-forth-auto680):04320 * (not * at address $140:)
+ (fig-forth-auto680):04321 * at an appropriate address:
+ (fig-forth-auto680):04322 *
+22A4 3000300000000000 (fig-forth-auto680):04323 RAM FDB $3000,$3000,0,0
+ (fig-forth-auto680):04324
+ (fig-forth-auto680):04325 * ======>> (152) <<
+ (fig-forth-auto680):04326 * ( --- ) P
+ (fig-forth-auto680):04327 * Makes FORTH the current interpretation vocabulary.
+ (fig-forth-auto680):04328 * In order to make this ROMmable, this entry is set up as the tail-end,
+ (fig-forth-auto680):04329 * and copied to RAM in the start-up code.
+ (fig-forth-auto680):04330 * We want a more elegant solution to this, too. Greedy, maybe.
+22AC C5 (fig-forth-auto680):04331 FCB $C5 immediate
+22AD 464F5254 (fig-forth-auto680):04332 FCC 'FORT' ; 'FORTH'
+22B1 C8 (fig-forth-auto680):04333 FCB $C8
+22B2 2A7C (fig-forth-auto680):04334 FDB NOOP-7 ; Note that this does not link to COLD!
+22B4 1C8621A181A02AC5 (fig-forth-auto680):04335 RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
+22BC 0000 (fig-forth-auto680):04336 FDB 0
+22BE 28432920466F7274 (fig-forth-auto680):04337 FCC "(C) Forth Interest Group, 1979"
+ 6820496E74657265
+ 73742047726F7570
+ 2C2031393739
+22DC 84 (fig-forth-auto680):04338 FCB $84
+22DD 544153 (fig-forth-auto680):04339 FCC 'TAS' ; 'TASK'
+22E0 CB (fig-forth-auto680):04340 FCB $CB
+22E1 2A95 (fig-forth-auto680):04341 FDB FORTH-8
+22E3 17B91667 (fig-forth-auto680):04342 RTASK FDB DOCOL,SEMIS
+22E7 4461766964204C69 (fig-forth-auto680):04343 ERAM FCC "David Lion"
+ 6F6E
+ (fig-forth-auto680):04344 PAGE
+ (fig-forth-auto680):04345 *
+ (fig-forth-auto680):04346 * ######>> screen 57 <<
+ (fig-forth-auto680):04347 * ======>> 158 <<
+ (fig-forth-auto680):04348 * ( n0 --- d0 )
+ (fig-forth-auto680):04349 * Sign extend n0 to a double integer.
+22F1 84 (fig-forth-auto680):04350 FCB $84
+22F2 532D3E (fig-forth-auto680):04351 FCC 'S->' ; 'S->D'
+22F5 C4 (fig-forth-auto680):04352 FCB $C4
+22F6 2224 (fig-forth-auto680):04353 FDB COLD-7 ; Note that this does not link to FORTH (RFORTH)!
+22F8 17B9174516B516EF (fig-forth-auto680):04354 STOD FDB DOCOL,DUP,ZLESS,MINUS
+2300 1667 (fig-forth-auto680):04355 FDB SEMIS
+ (fig-forth-auto680):04356
+ (fig-forth-auto680):04357
+ (fig-forth-auto680):04358 *
+ (fig-forth-auto680):04359 * ======>> 159 <<
+ (fig-forth-auto680):04360 * ( multiplier multiplicand --- product )
+ (fig-forth-auto680):04361 * Signed word multiply.
+2302 81 (fig-forth-auto680):04362 FCB $81 ; *
+2303 AA (fig-forth-auto680):04363 FCB $AA
+2304 22F1 (fig-forth-auto680):04364 FDB STOD-7
+2306 2308 (fig-forth-auto680):04365 STAR FDB *+NATWID
+2308 17F29C (fig-forth-auto680):04366 LBSR USTAR+NATWID ; or [USTAR,PCR]?
+230B 3342 (fig-forth-auto680):04367 LEAU NATWID,U ; Drop high word.
+230D 39 (fig-forth-auto680):04368 RTS
+ (fig-forth-auto680):04369 * JSR USTARS
+ (fig-forth-auto680):04370 * LEAS 1,S ;
+ (fig-forth-auto680):04371 * LEAS 1,S ;
+ (fig-forth-auto680):04372 * JMP NEXT
+ (fig-forth-auto680):04373 *
+ (fig-forth-auto680):04374 * ======>> 160 <<
+ (fig-forth-auto680):04375 * ( dividend divisor --- remainder quotient )
+ (fig-forth-auto680):04376 * M/ in word-only form, i. e., signed division of 2nd word by top word,
+ (fig-forth-auto680):04377 * yielding signed word quotient and remainder.
+230E 84 (fig-forth-auto680):04378 FCB $84
+230F 2F4D4F (fig-forth-auto680):04379 FCC '/MO' ; '/MOD'
+2312 C4 (fig-forth-auto680):04380 FCB $C4
+2313 2302 (fig-forth-auto680):04381 FDB STAR-4
+2315 17B9168122F81690 (fig-forth-auto680):04382 SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
+ 15DB
+231F 1667 (fig-forth-auto680):04383 FDB SEMIS
+ (fig-forth-auto680):04384 *
+ (fig-forth-auto680):04385 * ======>> 161 <<
+ (fig-forth-auto680):04386 * ( dividend divisor --- quotient )
+ (fig-forth-auto680):04387 * Signed word divide without remainder.
+2321 81 (fig-forth-auto680):04388 FCB $81 ; /
+2322 AF (fig-forth-auto680):04389 FCB $AF
+2323 230E (fig-forth-auto680):04390 FDB SLMOD-7
+2325 17B923151736172A (fig-forth-auto680):04391 SLASH FDB DOCOL,SLMOD,SWAP,DROP
+232D 1667 (fig-forth-auto680):04392 FDB SEMIS
+ (fig-forth-auto680):04393 *
+ (fig-forth-auto680):04394 * ======>> 162 <<
+ (fig-forth-auto680):04395 * ( dividend divisor --- remainder )
+ (fig-forth-auto680):04396 * Remainder function, result takes sign of dividend.
+232F 83 (fig-forth-auto680):04397 FCB $83
+2330 4D4F (fig-forth-auto680):04398 FCC 'MO' ; 'MOD'
+2332 C4 (fig-forth-auto680):04399 FCB $C4
+2333 2321 (fig-forth-auto680):04400 FDB SLASH-4
+2335 17B92315172A (fig-forth-auto680):04401 MOD FDB DOCOL,SLMOD,DROP
+233B 1667 (fig-forth-auto680):04402 FDB SEMIS
+ (fig-forth-auto680):04403 *
+ (fig-forth-auto680):04404 * ======>> 163 <<
+ (fig-forth-auto680):04405 * ( multiplier multiplicand divisor --- remainder quotient )
+ (fig-forth-auto680):04406 * Signed precise division of product:
+ (fig-forth-auto680):04407 * multiply 2nd and 3rd words on stack
+ (fig-forth-auto680):04408 * and divide the 31-bit product by the top word,
+ (fig-forth-auto680):04409 * leaving both quotient and remainder.
+ (fig-forth-auto680):04410 * Remainder takes sign of product.
+ (fig-forth-auto680):04411 * Guaranteed not to lose significant bits in 16 bit integer math.
+233D 85 (fig-forth-auto680):04412 FCB $85
+233E 2A2F4D4F (fig-forth-auto680):04413 FCC '*/MO' ; '*/MOD'
+2342 C4 (fig-forth-auto680):04414 FCB $C4
+2343 232F (fig-forth-auto680):04415 FDB MOD-6
+2345 17B9168115A51690 (fig-forth-auto680):04416 SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
+ 15DB
+234F 1667 (fig-forth-auto680):04417 FDB SEMIS
+ (fig-forth-auto680):04418 *
+ (fig-forth-auto680):04419 * ======>> 164 <<
+ (fig-forth-auto680):04420 * ( multiplier multiplicand divisor --- quotient )
+ (fig-forth-auto680):04421 * */MOD without remainder.
+2351 82 (fig-forth-auto680):04422 FCB $82
+2352 2A (fig-forth-auto680):04423 FCC '*' ; '*/'
+2353 AF (fig-forth-auto680):04424 FCB $AF
+2354 233D (fig-forth-auto680):04425 FDB SSMOD-8
+2356 17B923451736172A (fig-forth-auto680):04426 SSLASH FDB DOCOL,SSMOD,SWAP,DROP
+235E 1667 (fig-forth-auto680):04427 FDB SEMIS
+ (fig-forth-auto680):04428 *
+ (fig-forth-auto680):04429 * ======>> 165 <<
+ (fig-forth-auto680):04430 * ( ud1 u1 --- u2 ud2 )
+ (fig-forth-auto680):04431 * U/ with an (unsigned) double quotient.
+ (fig-forth-auto680):04432 * Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
+ (fig-forth-auto680):04433 * if you are prepared to deal with the extra 16 bits of result.
+2360 85 (fig-forth-auto680):04434 FCB $85
+2361 4D2F4D4F (fig-forth-auto680):04435 FCC 'M/MO' ; 'M/MOD'
+2365 C4 (fig-forth-auto680):04436 FCB $C4
+2366 2351 (fig-forth-auto680):04437 FDB SSLASH-5
+2368 17B91681183D169C (fig-forth-auto680):04438 MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
+ 15DB
+2372 16901736168115DB (fig-forth-auto680):04439 FDB FROMR,SWAP,TOR,USLASH,FROMR
+ 1690
+237C 1667 (fig-forth-auto680):04440 FDB SEMIS
+ (fig-forth-auto680):04441 *
+ (fig-forth-auto680):04442 * ======>> 166 <<
+ (fig-forth-auto680):04443 * ( n>=0 --- n )
+ (fig-forth-auto680):04444 * ( n<0 --- -n )
+ (fig-forth-auto680):04445 * Convert the top of stack to its absolute value.
+237E 83 (fig-forth-auto680):04446 FCB $83
+237F 4142 (fig-forth-auto680):04447 FCC 'AB' ; 'ABS'
+2381 D3 (fig-forth-auto680):04448 FCB $D3
+2382 2360 (fig-forth-auto680):04449 FDB MSMOD-8
+2384 17B9174516B51409 (fig-forth-auto680):04450 ABS FDB DOCOL,DUP,ZLESS,ZBRAN
+238C 0002 (fig-forth-auto680):04451 FDB ABS2-*-NATWID
+238E 16EF (fig-forth-auto680):04452 FDB MINUS
+2390 1667 (fig-forth-auto680):04453 ABS2 FDB SEMIS
+ (fig-forth-auto680):04454 *
+ (fig-forth-auto680):04455 * ======>> 167 <<
+ (fig-forth-auto680):04456 * ( d>=0 --- d )
+ (fig-forth-auto680):04457 * ( d<0 --- -d )
+ (fig-forth-auto680):04458 * Convert the top double to its absolute value.
+2392 84 (fig-forth-auto680):04459 FCB $84
+2393 444142 (fig-forth-auto680):04460 FCC 'DAB' ; 'DABS'
+2396 D3 (fig-forth-auto680):04461 FCB $D3
+2397 237E (fig-forth-auto680):04462 FDB ABS-6
+2399 17B9174516B51409 (fig-forth-auto680):04463 DABS FDB DOCOL,DUP,ZLESS,ZBRAN
+23A1 0002 (fig-forth-auto680):04464 FDB DABS2-*-NATWID
+23A3 1702 (fig-forth-auto680):04465 FDB DMINUS
+23A5 1667 (fig-forth-auto680):04466 DABS2 FDB SEMIS
+ (fig-forth-auto680):04467 *
+ (fig-forth-auto680):04468 * ######>> screen 58 <<
+ (fig-forth-auto680):04469 * Disc primitives :
+ (fig-forth-auto680):04470 * ======>> 168 <<
+ (fig-forth-auto680):04471 * ( --- vadr )
+ (fig-forth-auto680):04472 * Least Recently Used buffer.
+ (fig-forth-auto680):04473 * Really should be with FIRST and LIMIT in the per-task table.
+23A7 83 (fig-forth-auto680):04474 FCB $83
+23A8 5553 (fig-forth-auto680):04475 FCC 'US' ; 'USE'
+23AA C5 (fig-forth-auto680):04476 FCB $C5
+23AB 2392 (fig-forth-auto680):04477 FDB DABS-7
+23AD 17E9 (fig-forth-auto680):04478 USE FDB DOCON
+23AF 7C58 (fig-forth-auto680):04479 FDB XUSE
+ (fig-forth-auto680):04480 * ======>> 169 <<
+ (fig-forth-auto680):04481 * ( --- vadr )
+ (fig-forth-auto680):04482 * Most Recently Used buffer.
+ (fig-forth-auto680):04483 * Really should be with FIRST and LIMIT in the per-task table.
+23B1 84 (fig-forth-auto680):04484 FCB $84
+23B2 505245 (fig-forth-auto680):04485 FCC 'PRE' ; 'PREV'
+23B5 D6 (fig-forth-auto680):04486 FCB $D6
+23B6 23A7 (fig-forth-auto680):04487 FDB USE-6
+23B8 17E9 (fig-forth-auto680):04488 PREV FDB DOCON
+23BA 7C5A (fig-forth-auto680):04489 FDB XPREV
+ (fig-forth-auto680):04490 * ======>> 170 <<
+ (fig-forth-auto680):04491 * ( buffer1 --- buffer2 f )
+ (fig-forth-auto680):04492 * Bump to next buffer,
+ (fig-forth-auto680):04493 * flag false if result is PREVious buffer,
+ (fig-forth-auto680):04494 * otherwise flag true.
+ (fig-forth-auto680):04495 * Used in the LRU allocation routines.
+23BC 84 (fig-forth-auto680):04496 FCB $84
+23BD 2B4255 (fig-forth-auto680):04497 FCC '+BU' ; '+BUF'
+23C0 C6 (fig-forth-auto680):04498 FCB $C6
+23C1 23B1 (fig-forth-auto680):04499 FDB PREV-7
+23C3 17B913A7 (fig-forth-auto680):04500 PBUF FDB DOCOL,LIT8
+23C7 84 (fig-forth-auto680):04501 FCB $84
+23C8 16C6174518761A11 (fig-forth-auto680):04502 FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
+ 1409
+23D2 0004 (fig-forth-auto680):04503 FDB PBUF2-*-NATWID
+23D4 172A186A (fig-forth-auto680):04504 FDB DROP,FIRST
+23D8 174523B817721A04 (fig-forth-auto680):04505 PBUF2 FDB DUP,PREV,AT,SUB
+23E0 1667 (fig-forth-auto680):04506 FDB SEMIS
+ (fig-forth-auto680):04507 *
+ (fig-forth-auto680):04508 * ======>> 171 <<
+ (fig-forth-auto680):04509 * ( --- )
+ (fig-forth-auto680):04510 * Mark PREVious buffer dirty, in need of being written out.
+23E2 86 (fig-forth-auto680):04511 FCB $86
+23E3 5550444154 (fig-forth-auto680):04512 FCC 'UPDAT' ; 'UPDATE'
+23E8 C5 (fig-forth-auto680):04513 FCB $C5
+23E9 23BC (fig-forth-auto680):04514 FDB PBUF-7
+23EB 17B923B817721772 (fig-forth-auto680):04515 UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
+ 13998000161E23B8
+ 1772178A
+23FF 1667 (fig-forth-auto680):04516 FDB SEMIS
+ (fig-forth-auto680):04517 *
+ (fig-forth-auto680):04518 * ======>> 172 <<
+ (fig-forth-auto680):04519 * ( --- )
+ (fig-forth-auto680):04520 * Mark all buffers empty.
+ (fig-forth-auto680):04521 * Standard method of discarding changes.
+2401 8D (fig-forth-auto680):04522 FCB $8D
+2402 454D5054592D4255 (fig-forth-auto680):04523 FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
+ 46464552
+240E D3 (fig-forth-auto680):04524 FCB $D3
+240F 23E2 (fig-forth-auto680):04525 FDB UPDATE-9
+2411 17B9186A1876171C (fig-forth-auto680):04526 MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
+ 1A041E72
+241D 1667 (fig-forth-auto680):04527 FDB SEMIS
+ (fig-forth-auto680):04528 *
+ (fig-forth-auto680):04529 * ======>> 173 <<
+ (fig-forth-auto680):04530 * ( --- )
+ (fig-forth-auto680):04531 * Clear the current offset to the block numbers in the drive interface.
+ (fig-forth-auto680):04532 * The drives need to be re-architected.
+ (fig-forth-auto680):04533 * Would be cool to have RAM and ROM drives supported
+ (fig-forth-auto680):04534 * in addition to regular physical persistent store.
+241F 83 (fig-forth-auto680):04535 FCB $83
+2420 4452 (fig-forth-auto680):04536 FCC 'DR' ; 'DR0'
+2422 B0 (fig-forth-auto680):04537 FCB $B0
+2423 2401 (fig-forth-auto680):04538 FDB MTBUF-16
+2425 17B9183D1930178A (fig-forth-auto680):04539 DRZERO FDB DOCOL,ZERO,OFSET,STORE
+242D 1667 (fig-forth-auto680):04540 FDB SEMIS
+ (fig-forth-auto680):04541 *
+ (fig-forth-auto680):04542 * ======>> 174 <<== system dependant word
+ (fig-forth-auto680):04543 * ( --- )
+ (fig-forth-auto680):04544 * Set the current offset in the drive interface to reference the second drive.
+ (fig-forth-auto680):04545 * The hard-coded number in there needs to be in a table.
+242F 83 (fig-forth-auto680):04546 FCB $83
+2430 4452 (fig-forth-auto680):04547 FCC 'DR' ; 'DR1'
+2432 B1 (fig-forth-auto680):04548 FCB $B1
+2433 241F (fig-forth-auto680):04549 FDB DRZERO-6
+2435 17B9139907D01930 (fig-forth-auto680):04550 DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
+ 178A
+243F 1667 (fig-forth-auto680):04551 FDB SEMIS
+ (fig-forth-auto680):04552 *
+ (fig-forth-auto680):04553 * ######>> screen 59 <<
+ (fig-forth-auto680):04554 * ======>> 175 <<
+ (fig-forth-auto680):04555 * ( n --- buffer )
+ (fig-forth-auto680):04556 * Get a free buffer,
+ (fig-forth-auto680):04557 * assign it to block n,
+ (fig-forth-auto680):04558 * return buffer address.
+ (fig-forth-auto680):04559 * Will free a buffer by writing it, if necessary.
+ (fig-forth-auto680):04560 * Does not actually read the block.
+ (fig-forth-auto680):04561 * A bug in the fig LRU algorithm, which I have not fixed,
+ (fig-forth-auto680):04562 * gives the PREVious buffer if USE gets set to PREVious.
+ (fig-forth-auto680):04563 * (The bug is that USE sometimes gets set to PREVious.)
+ (fig-forth-auto680):04564 * This bug sometimes causes sector moves to become sector fills.
+2441 86 (fig-forth-auto680):04565 FCB $86
+2442 4255464645 (fig-forth-auto680):04566 FCC 'BUFFE' ; 'BUFFER'
+2447 D2 (fig-forth-auto680):04567 FCB $D2
+2448 242F (fig-forth-auto680):04568 FDB DRONE-6
+244A 17B923AD17721745 (fig-forth-auto680):04569 BUFFER FDB DOCOL,USE,AT,DUP,TOR
+ 1681
+2454 23C31409 (fig-forth-auto680):04570 BUFFR2 FDB PBUF,ZBRAN
+2458 FFFA (fig-forth-auto680):04571 FDB BUFFR2-*-NATWID
+245A 23AD178A169C1772 (fig-forth-auto680):04572 FDB USE,STORE,R,AT,ZLESS
+ 16B5
+2464 1409 (fig-forth-auto680):04573 FDB ZBRAN
+2466 0012 (fig-forth-auto680):04574 FDB BUFFR3-*-NATWID
+ (fig-forth-auto680):04575 * FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
+2468 169C1802169C1772 (fig-forth-auto680):04576 FDB R,NATP,R,AT,LIT,$7FFF,AND,ZERO,RW
+ 13997FFF160E183D
+ 263B
+ (fig-forth-auto680):04577 * BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
+247A 169C178A169C23B8 (fig-forth-auto680):04578 BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
+ 178A16901802
+2488 1667 (fig-forth-auto680):04579 FDB SEMIS
+ (fig-forth-auto680):04580 *
+ (fig-forth-auto680):04581 * ######>> screen 60 <<
+ (fig-forth-auto680):04582 * ======>> 176 <<
+ (fig-forth-auto680):04583 * ( n --- buffer )
+ (fig-forth-auto680):04584 * Get BUFFER containing block n, relative to OFFSET.
+ (fig-forth-auto680):04585 * If block n is not in a buffer, bring it in.
+ (fig-forth-auto680):04586 * Returns buffer address.
+248A 85 (fig-forth-auto680):04587 FCB $85
+248B 424C4F43 (fig-forth-auto680):04588 FCC 'BLOC' ; 'BLOCK'
+248F CB (fig-forth-auto680):04589 FCB $CB
+2490 2441 (fig-forth-auto680):04590 FDB BUFFER-9
+2492 17B91930177216C6 (fig-forth-auto680):04591 BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
+ 1681
+249C 23B8177217451772 (fig-forth-auto680):04592 FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
+ 169C1A04174516C6
+ 1409
+24AE 0032 (fig-forth-auto680):04593 FDB BLOCK5-*-NATWID
+24B0 23C316A31409 (fig-forth-auto680):04594 BLOCK3 FDB PBUF,ZEQU,ZBRAN
+24B6 0012 (fig-forth-auto680):04595 FDB BLOCK4-*-NATWID
+ (fig-forth-auto680):04596 * FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
+24B8 172A169C244A1745 (fig-forth-auto680):04597 FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
+ 169C1845263B17F7
+ 1A04
+24CA 17451772169C1A04 (fig-forth-auto680):04598 BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
+ 174516C616A31409
+24DA FFD4 (fig-forth-auto680):04599 FDB BLOCK3-*-NATWID
+24DC 174523B8178A (fig-forth-auto680):04600 FDB DUP,PREV,STORE
+ (fig-forth-auto680):04601 * BLOCK5 FDB FROMR,DROP,TWOP
+24E2 1690172A1802 (fig-forth-auto680):04602 BLOCK5 FDB FROMR,DROP,NATP
+24E8 1667 (fig-forth-auto680):04603 FDB SEMIS
+ (fig-forth-auto680):04604 *
+ (fig-forth-auto680):04605 * ######>> screen 61 <<
+ (fig-forth-auto680):04606 * ======>> 177 <<
+ (fig-forth-auto680):04607 * ( line screen --- buffer C/L)
+ (fig-forth-auto680):04608 * Bring in the sector containing the specified line of the specified screen.
+ (fig-forth-auto680):04609 * Returns the buffer address and the width of the screen.
+ (fig-forth-auto680):04610 * Screen number is relative to OFFSET.
+ (fig-forth-auto680):04611 * The line number may be beyond screen 4,
+ (fig-forth-auto680):04612 * (LINE) will get the appropriate screen.
+24EA 86 (fig-forth-auto680):04613 FCB $86
+24EB 284C494E45 (fig-forth-auto680):04614 FCC '(LINE' ; '(LINE)'
+24F0 A9 (fig-forth-auto680):04615 FCB $A9
+24F1 248A (fig-forth-auto680):04616 FDB BLOCK-8
+24F3 17B9168113A7 (fig-forth-auto680):04617 PLINE FDB DOCOL,TOR,LIT8
+24F9 40 (fig-forth-auto680):04618 FCB $40
+24FA 188223451690188E (fig-forth-auto680):04619 FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,LIT8
+ 230616C6249216C6
+ 13A7
+250C 40 (fig-forth-auto680):04620 FCB $40
+250D 1667 (fig-forth-auto680):04621 FDB SEMIS
+ (fig-forth-auto680):04622 *
+ (fig-forth-auto680):04623 * ======>> 178 <<
+ (fig-forth-auto680):04624 * ( line screen --- )
+ (fig-forth-auto680):04625 * Print the line of the screen as found by (LINE), suppress trailing BLANKS.
+250F 85 (fig-forth-auto680):04626 FCB $85
+2510 2E4C494E (fig-forth-auto680):04627 FCC '.LIN' ; '.LINE'
+2514 C5 (fig-forth-auto680):04628 FCB $C5
+2515 24EA (fig-forth-auto680):04629 FDB PLINE-9
+2517 17B924F31CDD1CAF (fig-forth-auto680):04630 DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
+251F 1667 (fig-forth-auto680):04631 FDB SEMIS
+ (fig-forth-auto680):04632 *
+ (fig-forth-auto680):04633 * ======>> 179 <<
+ (fig-forth-auto680):04634 * ( n --- )
+ (fig-forth-auto680):04635 * If WARNING is 0, print "MESSAGE #n";
+ (fig-forth-auto680):04636 * otherwise, print line n relative to screen 4,
+ (fig-forth-auto680):04637 * the line number may be negative.
+ (fig-forth-auto680):04638 * Uses .LINE, but counter-adjusts to be relative to the real drive 0.
+2521 87 (fig-forth-auto680):04639 FCB $87
+2522 4D4553534147 (fig-forth-auto680):04640 FCC 'MESSAG' ; 'MESSAGE'
+2528 C5 (fig-forth-auto680):04641 FCB $C5
+2529 250F (fig-forth-auto680):04642 FDB DLINE-8
+252B 17B918D817721409 (fig-forth-auto680):04643 MESS FDB DOCOL,WARN,AT,ZBRAN
+2533 0019 (fig-forth-auto680):04644 FDB MESS3-*-NATWID
+2535 1A8A1409 (fig-forth-auto680):04645 FDB DDUP,ZBRAN
+2539 0013 (fig-forth-auto680):04646 FDB MESS3-*-NATWID
+253B 13A7 (fig-forth-auto680):04647 FDB LIT8
+253D 04 (fig-forth-auto680):04648 FCB 4
+253E 19301772188E2325 (fig-forth-auto680):04649 FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
+ 1A04251713FA
+254C 000B (fig-forth-auto680):04650 FDB MESS4-*-NATWID
+254E 1D10 (fig-forth-auto680):04651 MESS3 FDB PDOTQ
+2550 06 (fig-forth-auto680):04652 FCB 6
+2551 657272202320 (fig-forth-auto680):04653 FCC 'err # ' ; 'err # '
+2557 28D6 (fig-forth-auto680):04654 FDB DOT
+2559 1667 (fig-forth-auto680):04655 MESS4 FDB SEMIS
+ (fig-forth-auto680):04656 *
+ (fig-forth-auto680):04657 * ======>> 180 <<
+ (fig-forth-auto680):04658 * ( n --- )
+ (fig-forth-auto680):04659 * Begin interpretation of screen (block) n.
+ (fig-forth-auto680):04660 * See also ARROW, SEMIS, and NULL.
+255B 84 (fig-forth-auto680):04661 FCB $84
+255C 4C4F41 (fig-forth-auto680):04662 FCC 'LOA' ; 'LOAD' : input:scr #
+255F C4 (fig-forth-auto680):04663 FCB $C4
+2560 2521 (fig-forth-auto680):04664 FDB MESS-10
+2562 17B9190617721681 (fig-forth-auto680):04665 LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
+ 190F17721681183D
+ 190F178A
+2576 188E23061906178A (fig-forth-auto680):04666 FDB BSCR,STAR,BLK,STORE
+257E 211D1690190F178A (fig-forth-auto680):04667 FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
+ 16901906178A
+258C 1667 (fig-forth-auto680):04668 FDB SEMIS
+ (fig-forth-auto680):04669 *
+ (fig-forth-auto680):04670 * ======>> 181 <<
+ (fig-forth-auto680):04671 * ( --- ) P
+ (fig-forth-auto680):04672 * Continue interpreting source code on the next screen.
+258E C3 (fig-forth-auto680):04673 FCB $C3
+258F 2D2D (fig-forth-auto680):04674 FCC '--' ; '-->'
+2591 BE (fig-forth-auto680):04675 FCB $BE
+2592 255B (fig-forth-auto680):04676 FDB LOAD-7
+2594 17B91BAE183D190F (fig-forth-auto680):04677 ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
+ 178A188E
+25A0 19061772171C2335 (fig-forth-auto680):04678 FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
+ 1A0419061751
+25AE 1667 (fig-forth-auto680):04679 FDB SEMIS
+ (fig-forth-auto680):04680 PAGE
+ (fig-forth-auto680):04681 *
+ (fig-forth-auto680):04682 *
+ (fig-forth-auto680):04683 * ######>> screen 63 <<
+ (fig-forth-auto680):04684 * The next 4 subroutines are machine dependent, and are
+ (fig-forth-auto680):04685 * called by words 13 through 16 in the dictionary.
+ (fig-forth-auto680):04686 *
+ (fig-forth-auto680):04687 * ======>> 182 << code for EMIT
+ (fig-forth-auto680):04688 * ( --- ) No parameter stack effect.
+ (fig-forth-auto680):04689 * Interfaces directly with ROM. Expects output character in D (therefore, B).
+ (fig-forth-auto680):04690 * Output using rom CHROUT: redirectable to a printer on Coco.
+ (fig-forth-auto680):04691 * Outputs the character on stack (low byte of 1 bit word/cell).
+25B0 3468 (fig-forth-auto680):04692 PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.)
+25B2 1F98 (fig-forth-auto680):04693 TFR B,A ; Coco ROM wants it in A.
+25B4 5F (fig-forth-auto680):04694 CLRB
+25B5 1F9B (fig-forth-auto680):04695 TFR B,DP ; Give the ROM its direct page.
+25B7 AD9FA002 (fig-forth-auto680):04696 JSR [$A002] ; Output the character in A.
+25BB 35E8 (fig-forth-auto680):04697 PULS Y,U,DP,PC
+ (fig-forth-auto680):04698 * PEMIT STB N save B
+ (fig-forth-auto680):04699 * STX N+1 save X
+ (fig-forth-auto680):04700 * LDB ACIAC
+ (fig-forth-auto680):04701 * BITB #2 check ready bit
+ (fig-forth-auto680):04702 * BEQ PEMIT+4 if not ready for more data
+ (fig-forth-auto680):04703 * STA ACIAD
+ (fig-forth-auto680):04704 * LDX UP
+ (fig-forth-auto680):04705 * STB IOSTAT-UORIG,X
+ (fig-forth-auto680):04706 * LDB N recover B & X
+ (fig-forth-auto680):04707 * LDX N+1
+ (fig-forth-auto680):04708 * RTS only A register may change
+ (fig-forth-auto680):04709 * PEMIT JMP $E1D1 for MIKBUG
+ (fig-forth-auto680):04710 * PEMIT FCB $3F,$11,$39 for PROTO
+ (fig-forth-auto680):04711 * PEMIT JMP $D286 for Smoke Signal DOS
+ (fig-forth-auto680):04712 *
+ (fig-forth-auto680):04713 * ======>> 183 << code for KEY
+ (fig-forth-auto680):04714 * ( --- ) No parameter stack effect.
+ (fig-forth-auto680):04715 * Returns character or break flag in D, since this interfaces with Coco ROM.
+ (fig-forth-auto680):04716 * Wait for key from POLCAT on Coco.
+ (fig-forth-auto680):04717 * Returns the character code for the key pressed.
+25BD 3468 (fig-forth-auto680):04718 PKEY PSHS Y,U,DP ; Must save everything important for this one.
+25BF 86CF (fig-forth-auto680):04719 LDA #$CF ; a cursor of sorts
+25C1 5F (fig-forth-auto680):04720 CLRB
+25C2 1F9B (fig-forth-auto680):04721 TFR B,DP
+ 00 (fig-forth-auto680):04722 SETDP 0
+25C4 9E88 (fig-forth-auto680):04723 LDX <$88 ; location
+25C6 E684 (fig-forth-auto680):04724 LDB ,X ; save glyph
+25C8 A784 (fig-forth-auto680):04725 STA ,X
+25CA AD9FA000 (fig-forth-auto680):04726 PKEYLP JSR [$A000]
+25CE B7041A (fig-forth-auto680):04727 STA $41A ; DBG!
+25D1 27F7 (fig-forth-auto680):04728 BEQ PKEYLP
+25D3 FD0418 (fig-forth-auto680):04729 STD $418 ; DBG!
+25D6 E784 (fig-forth-auto680):04730 STB ,X ; restore
+25D8 5F (fig-forth-auto680):04731 PKEYR CLRB ; for the break flag, shares code with PQTER
+25D9 8103 (fig-forth-auto680):04732 CMPA #3 ; break key
+25DB 2601 (fig-forth-auto680):04733 BNE PKEYGT
+25DD 53 (fig-forth-auto680):04734 COMB ; for the break flag
+25DE 1E89 (fig-forth-auto680):04735 PKEYGT EXG A,B ; Leave it in D for return.
+25E0 35E8 (fig-forth-auto680):04736 PULS Y,U,DP,PC ; Shares exit with PQTER
+ 7C (fig-forth-auto680):04737 SETDP IUPDP
+ (fig-forth-auto680):04738 * PKEY STB N
+ (fig-forth-auto680):04739 * STX N+1
+ (fig-forth-auto680):04740 * LDB ACIAC
+ (fig-forth-auto680):04741 * ASRB ;
+ (fig-forth-auto680):04742 * BCC PKEY+4 no incoming data yet
+ (fig-forth-auto680):04743 * LDA ACIAD
+ (fig-forth-auto680):04744 * ANDA #$7F strip parity bit
+ (fig-forth-auto680):04745 * LDX UP
+ (fig-forth-auto680):04746 * STB IOSTAT+1-UORIG,X
+ (fig-forth-auto680):04747 * LDB N
+ (fig-forth-auto680):04748 * LDX N+1
+ (fig-forth-auto680):04749 * RTS
+ (fig-forth-auto680):04750 * PKEY JMP $E1AC for MIKBUG
+ (fig-forth-auto680):04751 * PKEY FCB $3F,$14,$39 for PROTO
+ (fig-forth-auto680):04752 * PKEY JMP $D289 for Smoke Signal DOS
+ (fig-forth-auto680):04753 *
+ (fig-forth-auto680):04754 * ######>> screen 64 <<
+ (fig-forth-auto680):04755 * ======>> 184 << code for ?TERMINAL
+ (fig-forth-auto680):04756 * ( --- f ) Should change this to no stack effect.
+ (fig-forth-auto680):04757 * check break key using POLCAT
+ (fig-forth-auto680):04758 * Returns a flag to tell whether the break key was pressed or not.
+25E2 3468 (fig-forth-auto680):04759 PQTER PSHS Y,U,DP
+25E4 5F (fig-forth-auto680):04760 CLRB
+25E5 1F9B (fig-forth-auto680):04761 TFR B,DP
+25E7 AD9FA000 (fig-forth-auto680):04762 JSR [$A000] ; Look but don't wait.
+25EB 20EB (fig-forth-auto680):04763 BRA PKEYR
+ (fig-forth-auto680):04764 * PQTER LDA ACIAC Test for 'break' condition
+ (fig-forth-auto680):04765 * ANDA #$11 mask framing error bit and
+ (fig-forth-auto680):04766 * input buffer full
+ (fig-forth-auto680):04767 * BEQ PQTER2
+ (fig-forth-auto680):04768 * LDA ACIAD clear input buffer
+ (fig-forth-auto680):04769 * LDA #01
+ (fig-forth-auto680):04770 * PQTER2 RTS
+ (fig-forth-auto680):04771
+ (fig-forth-auto680):04772
+ (fig-forth-auto680):04773 PAGE
+ (fig-forth-auto680):04774 *
+ (fig-forth-auto680):04775 * ======>> 185 << code for CR
+ (fig-forth-auto680):04776 * ( --- ) No stack effect.
+ (fig-forth-auto680):04777 * Interfaces directly with ROM.
+ (fig-forth-auto680):04778 * For Coco just output a CR.
+ (fig-forth-auto680):04779 * Also subject to redirection in Coco BASIC ROM.
+25ED C60D (fig-forth-auto680):04780 PCR LDB #$0D
+25EF 20BF (fig-forth-auto680):04781 BRA PEMIT ; Just steal the code.
+ (fig-forth-auto680):04782 * PCR LDA #$D carriage return
+ (fig-forth-auto680):04783 * BSR PEMIT
+ (fig-forth-auto680):04784 * LDA #$A line feed
+ (fig-forth-auto680):04785 * BSR PEMIT
+ (fig-forth-auto680):04786 * LDA #$7F rubout
+ (fig-forth-auto680):04787 * LDX UP
+ (fig-forth-auto680):04788 * LDB XDELAY+1-UORIG,X
+ (fig-forth-auto680):04789 * PCR2 DECB ;
+ (fig-forth-auto680):04790 * BMI PQTER2 return if minus
+ (fig-forth-auto680):04791 * PSHS B ; save counter
+ (fig-forth-auto680):04792 * BSR PEMIT print RUBOUTs to delay.....
+ (fig-forth-auto680):04793 * PULS B ;
+ (fig-forth-auto680):04794 * BRA PCR2 repeat
+ (fig-forth-auto680):04795
+ (fig-forth-auto680):04796
+ (fig-forth-auto680):04797 PAGE
+ (fig-forth-auto680):04798 *
+ (fig-forth-auto680):04799 * ######>> screen 66 <<
+ (fig-forth-auto680):04800 * ======>> 187 <<
+ (fig-forth-auto680):04801 * ( ??? )
+ (fig-forth-auto680):04802 * Query the disk, I suppose.
+ (fig-forth-auto680):04803 * Not sure what the model had in mind for this stub.
+25F1 85 (fig-forth-auto680):04804 FCB $85
+25F2 3F444953 (fig-forth-auto680):04805 FCC '?DIS' ; '?DISC'
+25F6 C3 (fig-forth-auto680):04806 FCB $C3
+25F7 258E (fig-forth-auto680):04807 FDB ARROW-6
+25F9 25FB (fig-forth-auto680):04808 QDISC FDB *+NATWID
+25FB 7E1228 (fig-forth-auto680):04809 JMP NEXT
+ (fig-forth-auto680):04810 *
+ (fig-forth-auto680):04811 * ######>> screen 67 <<
+ (fig-forth-auto680):04812 * ======>> 189 <<
+ (fig-forth-auto680):04813 * ( ??? )
+ (fig-forth-auto680):04814 * Write one block of data to disk.
+ (fig-forth-auto680):04815 * Parameters unspecified in model. Stub in model.
+25FE 8B (fig-forth-auto680):04816 FCB $8B
+25FF 424C4F434B2D5752 (fig-forth-auto680):04817 FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
+ 4954
+2609 C5 (fig-forth-auto680):04818 FCB $C5
+260A 25F1 (fig-forth-auto680):04819 FDB QDISC-8
+260C 260E (fig-forth-auto680):04820 BWRITE FDB *+NATWID
+260E 7E1228 (fig-forth-auto680):04821 JMP NEXT
+ (fig-forth-auto680):04822 *
+ (fig-forth-auto680):04823 * ######>> screen 68 <<
+ (fig-forth-auto680):04824 * ======>> 190 <<
+ (fig-forth-auto680):04825 * ( ??? )
+ (fig-forth-auto680):04826 * Read one block of data from disk.
+ (fig-forth-auto680):04827 * Parameters unspecified in model. Stub in model.
+2611 8A (fig-forth-auto680):04828 FCB $8A
+2612 424C4F434B2D5245 (fig-forth-auto680):04829 FCC 'BLOCK-REA' ; 'BLOCK-READ'
+ 41
+261B C4 (fig-forth-auto680):04830 FCB $C4
+261C 25FE (fig-forth-auto680):04831 FDB BWRITE-14
+261E 2620 (fig-forth-auto680):04832 BREAD FDB *+NATWID
+2620 7E1228 (fig-forth-auto680):04833 JMP NEXT
+ (fig-forth-auto680):04834 *
+ (fig-forth-auto680):04835 *The next 3 words are written to create a substitute for disc
+ (fig-forth-auto680):04836 * mass memory,located between $3210 & $3FFF in ram.
+ (fig-forth-auto680):04837 * ======>> 190.1 <<
+2623 82 (fig-forth-auto680):04838 FCB $82
+2624 4C (fig-forth-auto680):04839 FCC 'L' ; 'LO'
+2625 CF (fig-forth-auto680):04840 FCB $CF
+2626 2611 (fig-forth-auto680):04841 FDB BREAD-13
+2628 17E9 (fig-forth-auto680):04842 LO FDB DOCON
+262A 7000 (fig-forth-auto680):04843 FDB MEMEND a system dependent equate at front
+ (fig-forth-auto680):04844 *
+ (fig-forth-auto680):04845 * ======>> 190.2 <<
+262C 82 (fig-forth-auto680):04846 FCB $82
+262D 48 (fig-forth-auto680):04847 FCC 'H' ; 'HI'
+262E C9 (fig-forth-auto680):04848 FCB $C9
+262F 2623 (fig-forth-auto680):04849 FDB LO-5
+2631 17E9 (fig-forth-auto680):04850 HI FDB DOCON
+2633 7FFF (fig-forth-auto680):04851 FDB MEMTOP ( $3FFF or $7FFF in this version )
+ (fig-forth-auto680):04852 *
+ (fig-forth-auto680):04853 * ######>> screen 69 <<
+ (fig-forth-auto680):04854 * ======>> 191 <<
+ (fig-forth-auto680):04855 * ( buffer sector f --- )
+ (fig-forth-auto680):04856 * Read or Write the specified (absolute -- ignores OFFSET) sector
+ (fig-forth-auto680):04857 * from or to the specified buffer.
+ (fig-forth-auto680):04858 * A zero flag specifies write,
+ (fig-forth-auto680):04859 * non-zero specifies read.
+ (fig-forth-auto680):04860 * Sector is an unsigned integer,
+ (fig-forth-auto680):04861 * buffer is the buffer's address.
+ (fig-forth-auto680):04862 * Will need to use the CoCo ROM disk routines.
+ (fig-forth-auto680):04863 * For now, provides a virtual disk in RAM.
+2635 83 (fig-forth-auto680):04864 FCB $83
+2636 522F (fig-forth-auto680):04865 FCC 'R/' ; 'R/W'
+2638 D7 (fig-forth-auto680):04866 FCB $D7
+2639 262C (fig-forth-auto680):04867 FDB HI-5
+263B 17B9168118822306 (fig-forth-auto680):04868 RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
+ 262816C617452631
+ 1A351409
+264F 000D (fig-forth-auto680):04869 FDB RW2-*-NATWID
+2651 1D10 (fig-forth-auto680):04870 FDB PDOTQ
+2653 08 (fig-forth-auto680):04871 FCB 8
+2654 2052616E6765203F (fig-forth-auto680):04872 FCC ' Range ?' ; ' Range ?'
+265C 21D7 (fig-forth-auto680):04873 FDB QUIT
+265E 16901409 (fig-forth-auto680):04874 RW2 FDB FROMR,ZBRAN
+2662 0002 (fig-forth-auto680):04875 FDB RW3-*-NATWID
+2664 1736 (fig-forth-auto680):04876 FDB SWAP
+2666 18821584 (fig-forth-auto680):04877 RW3 FDB BBUF,CMOVE
+266A 1667 (fig-forth-auto680):04878 FDB SEMIS
+ (fig-forth-auto680):04879 *
+ (fig-forth-auto680):04880 * From BIF-6809:
+ (fig-forth-auto680):04881 * RW PSHS Y,U,DP
+ (fig-forth-auto680):04882 * LDY $C006 control table
+ (fig-forth-auto680):04883 * LDX #DROFFS+7 ; This is BIF's table of drive sizes.
+ (fig-forth-auto680):04884 * LDD 2,U
+ (fig-forth-auto680):04885 * RWD SUBD ,X++ sectors
+ (fig-forth-auto680):04886 * BHS RWD
+ (fig-forth-auto680):04887 * BVC RWR table end?
+ (fig-forth-auto680):04888 * LDD #6
+ (fig-forth-auto680):04889 * PSHU D
+ (fig-forth-auto680):04890 * JMP ERROR
+ (fig-forth-auto680):04891 * RWR ADDD ,--X back one
+ (fig-forth-auto680):04892 * PSHS X
+ (fig-forth-auto680):04893 * PSHU D
+ (fig-forth-auto680):04894 * LDD #18 sectors/track
+ (fig-forth-auto680):04895 * PSHU D
+ (fig-forth-auto680):04896 * DOCOL
+ (fig-forth-auto680):04897 * FDB SLAMOD
+ (fig-forth-auto680):04898 * FDB XMACH
+ (fig-forth-auto680):04899 * PULU D
+ (fig-forth-auto680):04900 * STB 2,Y track
+ (fig-forth-auto680):04901 * PULU D
+ (fig-forth-auto680):04902 * INCB
+ (fig-forth-auto680):04903 * STB 3,Y sector
+ (fig-forth-auto680):04904 * PULS D table entry
+ (fig-forth-auto680):04905 * SUBD #DROFFS+7
+ (fig-forth-auto680):04906 * ASRB drive #
+ (fig-forth-auto680):04907 * STB 1,Y
+ (fig-forth-auto680):04908 * LDD 4,U buffer
+ (fig-forth-auto680):04909 * STD 4,Y
+ (fig-forth-auto680):04910 * LDB #2 coco READ
+ (fig-forth-auto680):04911 * LDX ,U 0?
+ (fig-forth-auto680):04912 * BNE *+3
+ (fig-forth-auto680):04913 * INCB coco WRITE
+ (fig-forth-auto680):04914 * STB ,Y op code
+ (fig-forth-auto680):04915 * CLRA
+ (fig-forth-auto680):04916 * TFR A,DP
+ (fig-forth-auto680):04917 * JSR [$C004] ROM handles timeout
+ (fig-forth-auto680):04918 * PULS Y,U,DP if IRQ enabled
+ (fig-forth-auto680):04919 * LEAU 6,U
+ (fig-forth-auto680):04920 * LDX $C006
+ (fig-forth-auto680):04921 * LDB 6,X coco status
+ (fig-forth-auto680):04922 * BEQ RWE
+ (fig-forth-auto680):04923 * LDX <UP
+ (fig-forth-auto680):04924 * LDD #0 no disc
+ (fig-forth-auto680):04925 * STD UWARN,X
+ (fig-forth-auto680):04926 * LDD #8
+ (fig-forth-auto680):04927 * PSHU D
+ (fig-forth-auto680):04928 * JMP ERROR
+ (fig-forth-auto680):04929 * RWE NEXT
+ (fig-forth-auto680):04930 *
+ (fig-forth-auto680):04931 * ######>> screen 72 <<
+ (fig-forth-auto680):04932 * ======>> 192 <<
+ (fig-forth-auto680):04933 * ( --- ) compiling P
+ (fig-forth-auto680):04934 * ( --- adr ) interpreting
+ (fig-forth-auto680):04935 * { ' name } input
+ (fig-forth-auto680):04936 * Parse a symbol name from input and search the dictionary for it, per -FIND;
+ (fig-forth-auto680):04937 * compile the address as a literal if compiling,
+ (fig-forth-auto680):04938 * otherwise just push it.
+266C C1 (fig-forth-auto680):04939 FCB $C1 immediate
+266D A7 (fig-forth-auto680):04940 FCB $A7 ' ( tick )
+266E 2635 (fig-forth-auto680):04941 FDB RW-6
+2670 17B91FAD16A3183D (fig-forth-auto680):04942 TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
+ 1B39172A20E2
+267E 1667 (fig-forth-auto680):04943 FDB SEMIS
+ (fig-forth-auto680):04944 *
+ (fig-forth-auto680):04945 * ======>> 193 <<
+ (fig-forth-auto680):04946 * ( --- ) { FORGET name } input
+ (fig-forth-auto680):04947 * Parse out name of definition to FORGET to, -DFIND it,
+ (fig-forth-auto680):04948 * then lop it and everything that follows out of the dictionary.
+ (fig-forth-auto680):04949 * In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
+2680 86 (fig-forth-auto680):04950 FCB $86
+2681 464F524745 (fig-forth-auto680):04951 FCC 'FORGE' ; 'FORGET'
+2686 D4 (fig-forth-auto680):04952 FCB $D4
+2687 266C (fig-forth-auto680):04953 FDB TICK-4
+2689 17B9194C1772193E (fig-forth-auto680):04954 FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,LIT8
+ 17721A0413A7
+2697 18 (fig-forth-auto680):04955 FCB $18
+2698 1B392670174518E4 (fig-forth-auto680):04956 FDB QERR,TICK,DUP,FENCE,AT,LESS,LIT8
+ 17721A1D13A7
+26A6 15 (fig-forth-auto680):04957 FCB $15
+26A7 1B391745183D189C (fig-forth-auto680):04958 FDB QERR,DUP,ZERO,PORIG,GREAT,LIT8
+ 1A3513A7
+26B3 15 (fig-forth-auto680):04959 FCB $15
+26B4 1B3917451AFD18ED (fig-forth-auto680):04960 FDB QERR,DUP,NFA,DICTPT,STORE,LFA,AT,CONTXT,AT,STORE
+ 178A1AE01772193E
+ 1772178A
+26C8 1667 (fig-forth-auto680):04961 FDB SEMIS
+ (fig-forth-auto680):04962 *
+ (fig-forth-auto680):04963 * ######>> screen 73 <<
+ (fig-forth-auto680):04964 * ======>> 194 <<
+ (fig-forth-auto680):04965 * ( adr --- ) C
+ (fig-forth-auto680):04966 * Calculate a back reference from HERE and compile it.
+26CA 84 (fig-forth-auto680):04967 FCB $84
+26CB 424143 (fig-forth-auto680):04968 FCC 'BAC' ; 'BACK'
+26CE CB (fig-forth-auto680):04969 FCB $CB
+26CF 2680 (fig-forth-auto680):04970 FDB FORGET-9
+ (fig-forth-auto680):04971 * BACK FDB DOCOL,HERE,SUB,COMMA
+26D1 17B919C718021A04 (fig-forth-auto680):04972 BACK FDB DOCOL,HERE,NATP,SUB,COMMA
+ 19E3
+26DB 1667 (fig-forth-auto680):04973 FDB SEMIS
+ (fig-forth-auto680):04974 *
+ (fig-forth-auto680):04975 * ======>> 195 <<
+ (fig-forth-auto680):04976 * ( --- ) runtime
+ (fig-forth-auto680):04977 * typical use: BEGIN code-loop test UNTIL
+ (fig-forth-auto680):04978 * typical use: BEGIN code-loop AGAIN
+ (fig-forth-auto680):04979 * typical use: BEGIN code-loop test WHILE code-true REPEAT
+ (fig-forth-auto680):04980 * ( --- adr n ) compile time P,C
+ (fig-forth-auto680):04981 * Push HERE for BACK reference for general (non-counting) loops,
+ (fig-forth-auto680):04982 * with BEGIN construct flag.
+ (fig-forth-auto680):04983 * A better flag: $4245 (ASCII for 'BE').
+26DD C5 (fig-forth-auto680):04984 FCB $C5
+26DE 42454749 (fig-forth-auto680):04985 FCC 'BEGI' ; 'BEGIN'
+26E2 CE (fig-forth-auto680):04986 FCB $CE
+26E3 26CA (fig-forth-auto680):04987 FDB BACK-7
+26E5 17B91B5319C71845 (fig-forth-auto680):04988 BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
+26ED 1667 (fig-forth-auto680):04989 FDB SEMIS
+ (fig-forth-auto680):04990 *
+ (fig-forth-auto680):04991 * ======>> 196 <<
+ (fig-forth-auto680):04992 * ( --- ) runtime
+ (fig-forth-auto680):04993 * typical use: test IF code-true ELSE code-false ENDIF
+ (fig-forth-auto680):04994 * ENDIF is just a sort of intersection piece,
+ (fig-forth-auto680):04995 * marking where execution resumes after both branches.
+ (fig-forth-auto680):04996 * ( adr n --- ) compile time
+ (fig-forth-auto680):04997 * Check the mark and resolve the IF.
+ (fig-forth-auto680):04998 * A better flag: $4846 (ASCII for 'IF').
+26EF C5 (fig-forth-auto680):04999 FCB $C5
+26F0 454E4449 (fig-forth-auto680):05000 FCC 'ENDI' ; 'ENDIF'
+26F4 C6 (fig-forth-auto680):05001 FCB $C6
+26F5 26DD (fig-forth-auto680):05002 FDB BEGIN-8
+26F7 17B91B53184D1B80 (fig-forth-auto680):05003 ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
+ 19C7
+2701 171C18021A041736 (fig-forth-auto680):05004 FDB OVER,NATP,SUB,SWAP,STORE
+ 178A
+270B 1667 (fig-forth-auto680):05005 FDB SEMIS
+ (fig-forth-auto680):05006 *
+ (fig-forth-auto680):05007 * ======>> 197 <<
+ (fig-forth-auto680):05008 * ( --- ) runtime
+ (fig-forth-auto680):05009 * typical use: test IF code-true ELSE code-false ENDIF
+ (fig-forth-auto680):05010 * ( adr n --- )
+ (fig-forth-auto680):05011 * Alias for ENDIF .
+270D C4 (fig-forth-auto680):05012 FCB $C4
+270E 544845 (fig-forth-auto680):05013 FCC 'THE' ; 'THEN'
+2711 CE (fig-forth-auto680):05014 FCB $CE
+2712 26EF (fig-forth-auto680):05015 FDB ENDIF-8
+2714 17B926F7 (fig-forth-auto680):05016 THEN FDB DOCOL,ENDIF
+2718 1667 (fig-forth-auto680):05017 FDB SEMIS
+ (fig-forth-auto680):05018 *
+ (fig-forth-auto680):05019 * ======>> 198 <<
+ (fig-forth-auto680):05020 * ( limit index --- ) runtime
+ (fig-forth-auto680):05021 * typical use: DO code-loop LOOP
+ (fig-forth-auto680):05022 * typical use: DO code-loop increment +LOOP
+ (fig-forth-auto680):05023 * Counted loop, index is initial value of index.
+ (fig-forth-auto680):05024 * Will loop until index equals (positive going)
+ (fig-forth-auto680):05025 * or passes (negative going) limit.
+ (fig-forth-auto680):05026 * ( --- adr n ) compile time P,C
+ (fig-forth-auto680):05027 * Compile (DO), push HERE for BACK reference,
+ (fig-forth-auto680):05028 * and push DO control construct flag.
+ (fig-forth-auto680):05029 * A better flag: $444F (ASCII for 'DO').
+271A C2 (fig-forth-auto680):05030 FCB $C2
+271B 44 (fig-forth-auto680):05031 FCC 'D' ; 'DO'
+271C CF (fig-forth-auto680):05032 FCB $CF
+271D 270D (fig-forth-auto680):05033 FDB THEN-7
+271F 17B91BC7145319C7 (fig-forth-auto680):05034 DO FDB DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
+ 1855
+2729 1667 (fig-forth-auto680):05035 FDB SEMIS
+ (fig-forth-auto680):05036 *
+ (fig-forth-auto680):05037 * ======>> 199 <<
+ (fig-forth-auto680):05038 * ( --- ) runtime
+ (fig-forth-auto680):05039 * typical use: DO code-loop LOOP
+ (fig-forth-auto680):05040 * Increments the index by one and branches back to beginning of loop.
+ (fig-forth-auto680):05041 * Will loop until index equals limit.
+ (fig-forth-auto680):05042 * ( adr n --- ) compile time P,C
+ (fig-forth-auto680):05043 * Check the mark and compile (LOOP), fill in BACK reference.
+ (fig-forth-auto680):05044 * A better flag: $444F (ASCII for 'DO').
+272B C4 (fig-forth-auto680):05045 FCB $C4
+272C 4C4F4F (fig-forth-auto680):05046 FCC 'LOO' ; 'LOOP'
+272F D0 (fig-forth-auto680):05047 FCB $D0
+2730 271A (fig-forth-auto680):05048 FDB DO-5
+2732 17B918551B801BC7 (fig-forth-auto680):05049 LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
+ 141D26D1
+273E 1667 (fig-forth-auto680):05050 FDB SEMIS
+ (fig-forth-auto680):05051 *
+ (fig-forth-auto680):05052 * ======>> 200 <<
+ (fig-forth-auto680):05053 * ( n --- ) runtime
+ (fig-forth-auto680):05054 * typical use: DO code-loop increment +LOOP
+ (fig-forth-auto680):05055 * Increments the index by n and branches back to beginning of loop.
+ (fig-forth-auto680):05056 * Will loop until index equals (positive going)
+ (fig-forth-auto680):05057 * or passes (negative going) limit.
+ (fig-forth-auto680):05058 * ( adr n --- ) compile time P,C
+ (fig-forth-auto680):05059 * Check the mark and compile (+LOOP), fill in BACK reference.
+ (fig-forth-auto680):05060 * A better flag: $444F (ASCII for 'DO').
+2740 C5 (fig-forth-auto680):05061 FCB $C5
+2741 2B4C4F4F (fig-forth-auto680):05062 FCC '+LOO' ; '+LOOP'
+2745 D0 (fig-forth-auto680):05063 FCB $D0
+2746 272B (fig-forth-auto680):05064 FDB LOOP-7
+2748 17B918551B801BC7 (fig-forth-auto680):05065 PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
+ 143C26D1
+2754 1667 (fig-forth-auto680):05066 FDB SEMIS
+ (fig-forth-auto680):05067 *
+ (fig-forth-auto680):05068 * ======>> 201 <<
+ (fig-forth-auto680):05069 * ( n --- ) runtime
+ (fig-forth-auto680):05070 * typical use: BEGIN code-loop test UNTIL
+ (fig-forth-auto680):05071 * Will loop until UNTIL tests true.
+ (fig-forth-auto680):05072 * ( adr n --- ) compile time P,C
+ (fig-forth-auto680):05073 * Check the mark and compile (0BRANCH), fill in BACK reference.
+ (fig-forth-auto680):05074 * A better flag: $4245 (ASCII for 'BE').
+2756 C5 (fig-forth-auto680):05075 FCB $C5
+2757 554E5449 (fig-forth-auto680):05076 FCC 'UNTI' ; 'UNTIL' : ( same as END )
+275B CC (fig-forth-auto680):05077 FCB $CC
+275C 2740 (fig-forth-auto680):05078 FDB PLOOP-8
+275E 17B918451B801BC7 (fig-forth-auto680):05079 UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
+ 140926D1
+276A 1667 (fig-forth-auto680):05080 FDB SEMIS
+ (fig-forth-auto680):05081 *
+ (fig-forth-auto680):05082 * ######>> screen 74 <<
+ (fig-forth-auto680):05083 * ======>> 202 <<
+ (fig-forth-auto680):05084 * ( n --- ) runtime
+ (fig-forth-auto680):05085 * typical use: BEGIN code-loop test END
+ (fig-forth-auto680):05086 * ( adr n --- )
+ (fig-forth-auto680):05087 * Alias for UNTIL .
+276C C3 (fig-forth-auto680):05088 FCB $C3
+276D 454E (fig-forth-auto680):05089 FCC 'EN' ; 'END'
+276F C4 (fig-forth-auto680):05090 FCB $C4
+2770 2756 (fig-forth-auto680):05091 FDB UNTIL-8
+2772 17B9275E (fig-forth-auto680):05092 END FDB DOCOL,UNTIL
+2776 1667 (fig-forth-auto680):05093 FDB SEMIS
+ (fig-forth-auto680):05094 *
+ (fig-forth-auto680):05095 * ======>> 203 <<
+ (fig-forth-auto680):05096 * ( --- ) runtime
+ (fig-forth-auto680):05097 * typical use: BEGIN code-loop AGAIN
+ (fig-forth-auto680):05098 * Will loop forever
+ (fig-forth-auto680):05099 * (or until something uses R> DROP to force the current definition to die,
+ (fig-forth-auto680):05100 * or perhaps ABORT or ERROR or some such other drastic means stops things).
+ (fig-forth-auto680):05101 * ( adr n --- ) compile time P,C
+ (fig-forth-auto680):05102 * Check the mark and compile (0BRANCH), fill in BACK reference.
+ (fig-forth-auto680):05103 * A better flag: $4245 (ASCII for 'BE').
+2778 C5 (fig-forth-auto680):05104 FCB $C5
+2779 41474149 (fig-forth-auto680):05105 FCC 'AGAI' ; 'AGAIN'
+277D CE (fig-forth-auto680):05106 FCB $CE
+277E 276C (fig-forth-auto680):05107 FDB END-6
+2780 17B918451B801BC7 (fig-forth-auto680):05108 AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
+ 13FA26D1
+278C 1667 (fig-forth-auto680):05109 FDB SEMIS
+ (fig-forth-auto680):05110 *
+ (fig-forth-auto680):05111 * ======>> 204 <<
+ (fig-forth-auto680):05112 * ( --- ) runtime
+ (fig-forth-auto680):05113 * typical use: BEGIN code-loop test WHILE code-true REPEAT
+ (fig-forth-auto680):05114 * Will loop until WHILE tests false, skipping code-true on end.
+ (fig-forth-auto680):05115 * REPEAT marks where execution resumes after the WHILE find a false flag.
+ (fig-forth-auto680):05116 * ( aadr1 n1 adr2 n2 --- ) compile time P,C
+ (fig-forth-auto680):05117 * Check the marks for WHILE and BEGIN,
+ (fig-forth-auto680):05118 * compile BRANCH and BACK fill adr1 reference,
+ (fig-forth-auto680):05119 * FILL-IN 0BRANCH reference at adr2.
+ (fig-forth-auto680):05120 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+278E C6 (fig-forth-auto680):05121 FCB $C6
+278F 5245504541 (fig-forth-auto680):05122 FCC 'REPEA' ; 'REPEAT'
+2794 D4 (fig-forth-auto680):05123 FCB $D4
+2795 2778 (fig-forth-auto680):05124 FDB AGAIN-8
+2797 17B9168116812780 (fig-forth-auto680):05125 REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
+ 16901690
+27A3 184D1A0426F7 (fig-forth-auto680):05126 FDB TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
+27A9 1667 (fig-forth-auto680):05127 FDB SEMIS
+ (fig-forth-auto680):05128 *
+ (fig-forth-auto680):05129 * ======>> 205 <<
+ (fig-forth-auto680):05130 * ( n --- ) runtime
+ (fig-forth-auto680):05131 * typical use: test IF code-true ELSE code-false ENDIF
+ (fig-forth-auto680):05132 * Will pass execution to the true part on a true flag
+ (fig-forth-auto680):05133 * and to the false part on a false flag.
+ (fig-forth-auto680):05134 * ( --- adr n ) compile time P,C
+ (fig-forth-auto680):05135 * Compile a 0BRANCH and dummy offset
+ (fig-forth-auto680):05136 * and push IF reference to fill in and
+ (fig-forth-auto680):05137 * IF control construct flag.
+ (fig-forth-auto680):05138 * A better flag: $4946 (ASCII for 'IF').
+27AB C2 (fig-forth-auto680):05139 FCB $C2
+27AC 49 (fig-forth-auto680):05140 FCC 'I' ; 'IF'
+27AD C6 (fig-forth-auto680):05141 FCB $C6
+27AE 278E (fig-forth-auto680):05142 FDB REPEAT-9
+27B0 17B91BC7140919C7 (fig-forth-auto680):05143 IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
+ 183D19E3184D
+27BE 1667 (fig-forth-auto680):05144 FDB SEMIS
+ (fig-forth-auto680):05145 *
+ (fig-forth-auto680):05146 * ======>> 206 <<
+ (fig-forth-auto680):05147 * ( --- ) runtime
+ (fig-forth-auto680):05148 * typical use: test IF code-true ELSE code-false ENDIF
+ (fig-forth-auto680):05149 * ELSE is just a sort of intersection piece,
+ (fig-forth-auto680):05150 * marking where execution resumes on a false branch.
+ (fig-forth-auto680):05151 * ( adr1 n --- adr2 n ) compile time P,C
+ (fig-forth-auto680):05152 * Check the marks,
+ (fig-forth-auto680):05153 * compile BRANCH with dummy offset,
+ (fig-forth-auto680):05154 * resolve IF reference,
+ (fig-forth-auto680):05155 * and leave reference to BRANCH for ELSE.
+ (fig-forth-auto680):05156 * A better flag: $4946 (ASCII for 'IF').
+27C0 C4 (fig-forth-auto680):05157 FCB $C4
+27C1 454C53 (fig-forth-auto680):05158 FCC 'ELS' ; 'ELSE'
+27C4 C5 (fig-forth-auto680):05159 FCB $C5
+27C5 27AB (fig-forth-auto680):05160 FDB IF-5
+27C7 17B9184D1B801BC7 (fig-forth-auto680):05161 ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
+ 13FA19C7
+27D3 183D19E31736184D (fig-forth-auto680):05162 FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
+ 26F7184D
+27DF 1667 (fig-forth-auto680):05163 FDB SEMIS
+ (fig-forth-auto680):05164 *
+ (fig-forth-auto680):05165 * ======>> 207 <<
+ (fig-forth-auto680):05166 * ( n --- ) runtime
+ (fig-forth-auto680):05167 * typical use: BEGIN code-loop test WHILE code-true REPEAT
+ (fig-forth-auto680):05168 * Will loop until WHILE tests false, skipping code-true on end.
+ (fig-forth-auto680):05169 * ( --- adr n ) compile time P,C
+ (fig-forth-auto680):05170 * Compile 0BRANCH with dummy offset (using IF),
+ (fig-forth-auto680):05171 * push WHILE reference.
+ (fig-forth-auto680):05172 * BEGIN flag will sit underneath this.
+ (fig-forth-auto680):05173 * Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
+27E1 C5 (fig-forth-auto680):05174 FCB $C5
+27E2 5748494C (fig-forth-auto680):05175 FCC 'WHIL' ; 'WHILE'
+27E6 C5 (fig-forth-auto680):05176 FCB $C5
+27E7 27C0 (fig-forth-auto680):05177 FDB ELSE-7
+27E9 17B927B019B8 (fig-forth-auto680):05178 WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
+27EF 1667 (fig-forth-auto680):05179 FDB SEMIS
+ (fig-forth-auto680):05180 *
+ (fig-forth-auto680):05181 * ######>> screen 75 <<
+ (fig-forth-auto680):05182 * ======>> 208 <<
+ (fig-forth-auto680):05183 * ( count --- )
+ (fig-forth-auto680):05184 * EMIT count spaces, for non-zero, non-negative counts.
+27F1 86 (fig-forth-auto680):05185 FCB $86
+27F2 5350414345 (fig-forth-auto680):05186 FCC 'SPACE' ; 'SPACES'
+27F7 D3 (fig-forth-auto680):05187 FCB $D3
+27F8 27E1 (fig-forth-auto680):05188 FDB WHILE-8
+27FA 17B9183D1A771A8A (fig-forth-auto680):05189 SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
+ 1409
+2804 000A (fig-forth-auto680):05190 FDB SPACE3-*-NATWID
+2806 183D1453 (fig-forth-auto680):05191 FDB ZERO,XDO
+280A 1A57141D (fig-forth-auto680):05192 SPACE2 FDB SPACE,XLOOP
+280E FFFA (fig-forth-auto680):05193 FDB SPACE2-*-NATWID
+2810 1667 (fig-forth-auto680):05194 SPACE3 FDB SEMIS
+ (fig-forth-auto680):05195 *
+ (fig-forth-auto680):05196 * ======>> 209 <<
+ (fig-forth-auto680):05197 * ( --- )
+ (fig-forth-auto680):05198 * Initialize HLD for converting a double integer.
+ (fig-forth-auto680):05199 * Stores the PAD address in HLD.
+2812 82 (fig-forth-auto680):05200 FCB $82
+2813 3C (fig-forth-auto680):05201 FCC '<' ; '<#'
+2814 A3 (fig-forth-auto680):05202 FCB $A3
+2815 27F1 (fig-forth-auto680):05203 FDB SPACES-9
+2817 17B91EAA1994178A (fig-forth-auto680):05204 BDIGS FDB DOCOL,PAD,HLD,STORE
+281F 1667 (fig-forth-auto680):05205 FDB SEMIS
+ (fig-forth-auto680):05206 *
+ (fig-forth-auto680):05207 * ======>> 210 <<
+ (fig-forth-auto680):05208 * ( d --- string length )
+ (fig-forth-auto680):05209 * Terminate numeric conversion,
+ (fig-forth-auto680):05210 * drop the number being converted,
+ (fig-forth-auto680):05211 * leave the address of the conversion string and the length, ready for TYPE.
+2821 82 (fig-forth-auto680):05212 FCB $82
+2822 23 (fig-forth-auto680):05213 FCC '#' ; '#>'
+2823 BE (fig-forth-auto680):05214 FCB $BE
+2824 2812 (fig-forth-auto680):05215 FDB BDIGS-5
+2826 17B9172A172A1994 (fig-forth-auto680):05216 EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
+ 17721EAA171C1A04
+2836 1667 (fig-forth-auto680):05217 FDB SEMIS
+ (fig-forth-auto680):05218 *
+ (fig-forth-auto680):05219 * ======>> 211 <<
+ (fig-forth-auto680):05220 * ( n d --- d )
+ (fig-forth-auto680):05221 * Put sign of n (as a flag) at the head of the conversion string.
+ (fig-forth-auto680):05222 * Drop the sign flag.
+2838 84 (fig-forth-auto680):05223 FCB $84
+2839 534947 (fig-forth-auto680):05224 FCC 'SIG' ; 'SIGN'
+283C CE (fig-forth-auto680):05225 FCB $CE
+283D 2821 (fig-forth-auto680):05226 FDB EDIGS-5
+283F 17B91A4316B51409 (fig-forth-auto680):05227 SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
+2847 0005 (fig-forth-auto680):05228 FDB SIGN2-*-NATWID
+2849 13A7 (fig-forth-auto680):05229 FDB LIT8
+284B 2D (fig-forth-auto680):05230 FCC "-"
+284C 1E92 (fig-forth-auto680):05231 FDB HOLD
+284E 1667 (fig-forth-auto680):05232 SIGN2 FDB SEMIS
+ (fig-forth-auto680):05233 *
+ (fig-forth-auto680):05234 * ======>> 212 <<
+ (fig-forth-auto680):05235 * ( d --- d/base )
+ (fig-forth-auto680):05236 * Generate next most significant digit in the conversion BASE,
+ (fig-forth-auto680):05237 * putting the digit at the head of the conversion string.
+2850 81 (fig-forth-auto680):05238 FCB $81 #
+2851 A3 (fig-forth-auto680):05239 FCB $A3
+2852 2838 (fig-forth-auto680):05240 FDB SIGN-7
+2854 17B9196317722368 (fig-forth-auto680):05241 DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
+ 1A4313A7
+2860 09 (fig-forth-auto680):05242 FCB 9
+2861 171C1A1D1409 (fig-forth-auto680):05243 FDB OVER,LESS,ZBRAN
+2867 0005 (fig-forth-auto680):05244 FDB DIG2-*-NATWID
+2869 13A7 (fig-forth-auto680):05245 FDB LIT8
+286B 07 (fig-forth-auto680):05246 FCB 7
+286C 16C6 (fig-forth-auto680):05247 FDB PLUS
+286E 13A7 (fig-forth-auto680):05248 DIG2 FDB LIT8
+2870 30 (fig-forth-auto680):05249 FCC "0" ascii zero
+2871 16C61E92 (fig-forth-auto680):05250 FDB PLUS,HOLD
+2875 1667 (fig-forth-auto680):05251 FDB SEMIS
+ (fig-forth-auto680):05252 *
+ (fig-forth-auto680):05253 * ======>> 213 <<
+ (fig-forth-auto680):05254 * ( d --- dzero )
+ (fig-forth-auto680):05255 * Convert d to a numeric string using # until the result is zero.
+ (fig-forth-auto680):05256 * Leave the double result on the stack for #> to drop.
+2877 82 (fig-forth-auto680):05257 FCB $82
+2878 23 (fig-forth-auto680):05258 FCC '#' ; '#S'
+2879 D3 (fig-forth-auto680):05259 FCB $D3
+287A 2850 (fig-forth-auto680):05260 FDB DIG-4
+287C 17B9 (fig-forth-auto680):05261 DIGS FDB DOCOL
+287E 2854171C171C161E (fig-forth-auto680):05262 DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
+ 16A31409
+288A FFF2 (fig-forth-auto680):05263 FDB DIGS2-*-NATWID
+288C 1667 (fig-forth-auto680):05264 FDB SEMIS
+ (fig-forth-auto680):05265 *
+ (fig-forth-auto680):05266 * ######>> screen 76 <<
+ (fig-forth-auto680):05267 * ======>> 214 <<
+ (fig-forth-auto680):05268 * ( n width --- )
+ (fig-forth-auto680):05269 * Print n on the output device in the current conversion base,
+ (fig-forth-auto680):05270 * with sign,
+ (fig-forth-auto680):05271 * right aligned in a field at least width wide.
+288E 82 (fig-forth-auto680):05272 FCB $82
+288F 2E (fig-forth-auto680):05273 FCC '.' ; '.R'
+2890 D2 (fig-forth-auto680):05274 FCB $D2
+2891 2877 (fig-forth-auto680):05275 FDB DIGS-5
+2893 17B9168122F81690 (fig-forth-auto680):05276 DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
+ 28A5
+289D 1667 (fig-forth-auto680):05277 FDB SEMIS
+ (fig-forth-auto680):05278 *
+ (fig-forth-auto680):05279 * ======>> 215 <<
+ (fig-forth-auto680):05280 * ( d width --- )
+ (fig-forth-auto680):05281 * Print d on the output device in the current conversion base,
+ (fig-forth-auto680):05282 * with sign,
+ (fig-forth-auto680):05283 * right aligned in a field at least width wide.
+289F 83 (fig-forth-auto680):05284 FCB $83
+28A0 442E (fig-forth-auto680):05285 FCC 'D.' ; 'D.R'
+28A2 D2 (fig-forth-auto680):05286 FCB $D2
+28A3 288E (fig-forth-auto680):05287 FDB DOTR-5
+28A5 17B916811736171C (fig-forth-auto680):05288 DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
+ 23992817287C283F
+28B5 28261690171C1A04 (fig-forth-auto680):05289 FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
+ 27FA1CAF
+28C1 1667 (fig-forth-auto680):05290 FDB SEMIS
+ (fig-forth-auto680):05291 *
+ (fig-forth-auto680):05292 * ======>> 216 <<
+ (fig-forth-auto680):05293 * D. ( d --- )
+ (fig-forth-auto680):05294 * Print d on the output device in the current conversion base,
+ (fig-forth-auto680):05295 * with sign,
+ (fig-forth-auto680):05296 * in free format with trailing space.
+28C3 82 (fig-forth-auto680):05297 FCB $82
+28C4 44 (fig-forth-auto680):05298 FCC 'D' ; 'D.'
+28C5 AE (fig-forth-auto680):05299 FCB $AE
+28C6 289F (fig-forth-auto680):05300 FDB DDOTR-6
+28C8 17B9183D28A51A57 (fig-forth-auto680):05301 DDOT FDB DOCOL,ZERO,DDOTR,SPACE
+28D0 1667 (fig-forth-auto680):05302 FDB SEMIS
+ (fig-forth-auto680):05303 *
+ (fig-forth-auto680):05304 * ======>> 217 <<
+ (fig-forth-auto680):05305 * ( n --- )
+ (fig-forth-auto680):05306 * Print n on the output device in the current conversion base,
+ (fig-forth-auto680):05307 * with sign,
+ (fig-forth-auto680):05308 * in free format with trailing space.
+28D2 81 (fig-forth-auto680):05309 FCB $81 .
+28D3 AE (fig-forth-auto680):05310 FCB $AE
+28D4 28C3 (fig-forth-auto680):05311 FDB DDOT-5
+28D6 17B922F828C8 (fig-forth-auto680):05312 DOT FDB DOCOL,STOD,DDOT
+28DC 1667 (fig-forth-auto680):05313 FDB SEMIS
+ (fig-forth-auto680):05314 *
+ (fig-forth-auto680):05315 * ======>> 218 <<
+ (fig-forth-auto680):05316 * ( adr --- )
+ (fig-forth-auto680):05317 * Print signed word at adr, per DOT.
+28DE 81 (fig-forth-auto680):05318 FCB $81 ?
+28DF BF (fig-forth-auto680):05319 FCB $BF
+28E0 28D2 (fig-forth-auto680):05320 FDB DOT-4
+28E2 17B9177228D6 (fig-forth-auto680):05321 QUEST FDB DOCOL,AT,DOT
+28E8 1667 (fig-forth-auto680):05322 FDB SEMIS
+ (fig-forth-auto680):05323 *
+ (fig-forth-auto680):05324 * ######>> screen 77 <<
+ (fig-forth-auto680):05325 * ======>> 219 <<
+ (fig-forth-auto680):05326 * ( n --- )
+ (fig-forth-auto680):05327 * Print out screen n as a field of ASCII,
+ (fig-forth-auto680):05328 * with line numbers in decimal.
+ (fig-forth-auto680):05329 * Needs a console more than 70 characters wide.
+28EA 84 (fig-forth-auto680):05330 FCB $84
+28EB 4C4953 (fig-forth-auto680):05331 FCC 'LIS' ; 'LIST'
+28EE D4 (fig-forth-auto680):05332 FCB $D4
+28EF 28DE (fig-forth-auto680):05333 FDB QUEST-4
+28F1 17B91C2515771745 (fig-forth-auto680):05334 LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
+ 1923178A1D10
+28FF 06 (fig-forth-auto680):05335 FCB 6
+2900 534352202320 (fig-forth-auto680):05336 FCC "SCR # "
+2906 28D613A7 (fig-forth-auto680):05337 FDB DOT,LIT8
+290A 10 (fig-forth-auto680):05338 FCB $10
+290B 183D1453 (fig-forth-auto680):05339 FDB ZERO,XDO
+290F 157714651855 (fig-forth-auto680):05340 LIST2 FDB CR,I,THREE
+2915 28931A5714651923 (fig-forth-auto680):05341 FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
+ 17722517141D
+2923 FFEA (fig-forth-auto680):05342 FDB LIST2-*-NATWID
+2925 1577 (fig-forth-auto680):05343 FDB CR
+2927 1667 (fig-forth-auto680):05344 FDB SEMIS
+ (fig-forth-auto680):05345 *
+ (fig-forth-auto680):05346 * ======>> 220 <<
+ (fig-forth-auto680):05347 * ( start end --- )
+ (fig-forth-auto680):05348 * Print comment lines (line 0, and line 1 if C/L < 41) of screens
+ (fig-forth-auto680):05349 * from start to end.
+ (fig-forth-auto680):05350 * Needs a console more than 70 characters wide.
+2929 85 (fig-forth-auto680):05351 FCB $85
+292A 494E4445 (fig-forth-auto680):05352 FCC 'INDE' ; 'INDEX'
+292E D8 (fig-forth-auto680):05353 FCB $D8
+292F 28EA (fig-forth-auto680):05354 FDB LIST-7
+2931 17B9157719AB1736 (fig-forth-auto680):05355 INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
+ 1453
+293B 157714651855 (fig-forth-auto680):05356 INDEX2 FDB CR,I,THREE
+2941 28931A57183D1465 (fig-forth-auto680):05357 FDB DOTR,SPACE,ZERO,I,DLINE
+ 2517
+294B 156A1409 (fig-forth-auto680):05358 FDB QTERM,ZBRAN
+294F 0002 (fig-forth-auto680):05359 FDB INDEX3-*-NATWID
+2951 1675 (fig-forth-auto680):05360 FDB LEAVE
+2953 141D (fig-forth-auto680):05361 INDEX3 FDB XLOOP
+2955 FFE4 (fig-forth-auto680):05362 FDB INDEX2-*-NATWID
+2957 1667 (fig-forth-auto680):05363 FDB SEMIS
+ (fig-forth-auto680):05364 *
+ (fig-forth-auto680):05365 * ======>> 221 <<
+ (fig-forth-auto680):05366 * ( n --- )
+ (fig-forth-auto680):05367 * List a printer page full of screens.
+ (fig-forth-auto680):05368 * Line and screen number are in current base.
+ (fig-forth-auto680):05369 * Needs a console more than 70 characters wide.
+2959 85 (fig-forth-auto680):05370 FCB $85
+295A 54524941 (fig-forth-auto680):05371 FCC 'TRIA' ; 'TRIAD'
+295E C4 (fig-forth-auto680):05372 FCB $C4
+295F 2929 (fig-forth-auto680):05373 FDB INDEX-8
+2961 17B9185523251855 (fig-forth-auto680):05374 TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
+ 2306
+296B 1855171C16C61736 (fig-forth-auto680):05375 FDB THREE,OVER,PLUS,SWAP,XDO
+ 1453
+2975 15771465 (fig-forth-auto680):05376 TRIAD2 FDB CR,I
+2979 28F1156A1409 (fig-forth-auto680):05377 FDB LIST,QTERM,ZBRAN
+297F 0002 (fig-forth-auto680):05378 FDB TRIAD3-*-NATWID
+2981 1675 (fig-forth-auto680):05379 FDB LEAVE
+2983 141D (fig-forth-auto680):05380 TRIAD3 FDB XLOOP
+2985 FFEE (fig-forth-auto680):05381 FDB TRIAD2-*-NATWID
+2987 157713A7 (fig-forth-auto680):05382 FDB CR,LIT8
+298B 0F (fig-forth-auto680):05383 FCB $0F
+298C 252B1577 (fig-forth-auto680):05384 FDB MESS,CR
+2990 1667 (fig-forth-auto680):05385 FDB SEMIS
+ (fig-forth-auto680):05386 *
+ (fig-forth-auto680):05387 * ######>> screen 78 <<
+ (fig-forth-auto680):05388 * ======>> 222 <<
+ (fig-forth-auto680):05389 * ( --- )
+ (fig-forth-auto680):05390 * Alphabetically list the definitions in the current vocabulary.
+ (fig-forth-auto680):05391 * Expects to output to printer, not TRS80 Color Computer screen.
+2992 85 (fig-forth-auto680):05392 FCB $85
+2993 564C4953 (fig-forth-auto680):05393 FCC 'VLIS' ; 'VLIST'
+2997 D4 (fig-forth-auto680):05394 FCB $D4
+2998 2959 (fig-forth-auto680):05395 FDB TRIAD-8
+299A 17B913A7 (fig-forth-auto680):05396 VLIST FDB DOCOL,LIT8
+299E 80 (fig-forth-auto680):05397 FCB $80
+299F 1919178A193E1772 (fig-forth-auto680):05398 FDB OUT,STORE,CONTXT,AT,AT
+ 1772
+29A9 1919177219A21772 (fig-forth-auto680):05399 VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
+ 13A7
+29B3 20 (fig-forth-auto680):05400 FCB 32
+29B4 1A041A351409 (fig-forth-auto680):05401 FDB SUB,GREAT,ZBRAN
+29BA 0008 (fig-forth-auto680):05402 FDB VLIST2-*-NATWID
+29BC 1577183D1919178A (fig-forth-auto680):05403 FDB CR,ZERO,OUT,STORE
+29C4 174520301A571A57 (fig-forth-auto680):05404 VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
+ 1B121AE01772
+29D2 174516A3156A161E (fig-forth-auto680):05405 FDB DUP,ZEQU,QTERM,OR,ZBRAN
+ 1409
+29DC FFCB (fig-forth-auto680):05406 FDB VLIST1-*-NATWID
+29DE 172A (fig-forth-auto680):05407 FDB DROP
+29E0 1667 (fig-forth-auto680):05408 FDB SEMIS
+ (fig-forth-auto680):05409 *
+ (fig-forth-auto680):05410 * Need some utility stuff that isn't in the fig FORTH:
+ (fig-forth-auto680):05411 * ( c --- )
+ (fig-forth-auto680):05412 * Emit dot if c is less than blank, else emit c
+29E2 85 (fig-forth-auto680):05413 FCB $85
+29E3 42454D49 (fig-forth-auto680):05414 FCC 'BEMI' ; 'BEMIT'
+29E7 D4 (fig-forth-auto680):05415 FCB $D4 ; 'T'
+29E8 2992 (fig-forth-auto680):05416 FDB VLIST-8
+29EA 17B9 (fig-forth-auto680):05417 BEMIT FDB DOCOL
+29EC 1745185E1A1D1409 (fig-forth-auto680):05418 FDB DUP,BL,LESS,ZBRAN
+29F4 0005 (fig-forth-auto680):05419 FDB BEMITO-*-NATWID
+29F6 172A13A7 (fig-forth-auto680):05420 FDB DROP,LIT8
+29FA 2E (fig-forth-auto680):05421 FCB $2e ; '.'
+29FB 1542 (fig-forth-auto680):05422 BEMITO FDB EMIT
+29FD 1667 (fig-forth-auto680):05423 FDB SEMIS
+ (fig-forth-auto680):05424 *
+ (fig-forth-auto680):05425 * ( n width --- )
+ (fig-forth-auto680):05426 * Output n in hexadecimal field width.
+29FF 83 (fig-forth-auto680):05427 FCB $83
+2A00 582E (fig-forth-auto680):05428 FCC 'X.' ; 'X.R'
+2A02 D2 (fig-forth-auto680):05429 FCB $D2 ; 'R'
+2A03 29E2 (fig-forth-auto680):05430 FDB BEMIT-8
+2A05 17B9 (fig-forth-auto680):05431 XDOTR FDB DOCOL
+2A07 1963177216811C10 (fig-forth-auto680):05432 FDB BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
+ 289316901963178A
+2A17 1667 (fig-forth-auto680):05433 FDB SEMIS
+ (fig-forth-auto680):05434 *
+ (fig-forth-auto680):05435 * ( adr --- )
+ (fig-forth-auto680):05436 * Dump a line of 4 bytes in memory, in hex and as characters.
+2A19 85 (fig-forth-auto680):05437 FCB $85
+2A1A 424C494E (fig-forth-auto680):05438 FCC 'BLIN' ; 'BLINE'
+2A1E C5 (fig-forth-auto680):05439 FCB $C5 ; 'E'
+2A1F 29FF (fig-forth-auto680):05440 FDB XDOTR-6
+2A21 17B9 (fig-forth-auto680):05441 BLINE FDB DOCOL
+2A23 174513A7 (fig-forth-auto680):05442 FDB DUP,LIT8
+2A27 04 (fig-forth-auto680):05443 FCB 4
+2A28 16C6171C1453 (fig-forth-auto680):05444 FDB PLUS,OVER,XDO
+2A2E 1465177E18552A05 (fig-forth-auto680):05445 BLINEX FDB I,CAT,THREE,XDOTR,XLOOP
+ 141D
+2A38 FFF4 (fig-forth-auto680):05446 FDB BLINEX-*-NATWID
+2A3A 1A571A57 (fig-forth-auto680):05447 FDB SPACE,SPACE
+2A3E 174513A7 (fig-forth-auto680):05448 FDB DUP,LIT8
+2A42 04 (fig-forth-auto680):05449 FCB 4
+2A43 17361453 (fig-forth-auto680):05450 FDB SWAP,XDO
+2A47 1465177E29EA141D (fig-forth-auto680):05451 BLINEC FDB I,CAT,BEMIT,XLOOP
+2A4F FFF6 (fig-forth-auto680):05452 FDB BLINEC-*-NATWID
+2A51 1667 (fig-forth-auto680):05453 FDB SEMIS
+ (fig-forth-auto680):05454 *
+ (fig-forth-auto680):05455 * ( start end --- )
+ (fig-forth-auto680):05456 * Dump 4 byte lines from start to end.
+2A53 85 (fig-forth-auto680):05457 FCB $85
+2A54 4244554D (fig-forth-auto680):05458 FCC 'BDUM' ; 'BDUMP'
+2A58 D0 (fig-forth-auto680):05459 FCB $D0 ; '5'
+2A59 2A19 (fig-forth-auto680):05460 FDB BLINE-8
+2A5B 17B9 (fig-forth-auto680):05461 BDUMP FDB DOCOL
+2A5D 1453 (fig-forth-auto680):05462 FDB XDO
+2A5F 146513A7 (fig-forth-auto680):05463 BDUMPL FDB I,LIT8
+2A63 04 (fig-forth-auto680):05464 FCB 4
+2A64 2A0513A7 (fig-forth-auto680):05465 FDB XDOTR,LIT8
+2A68 3A (fig-forth-auto680):05466 FCB $3A
+2A69 15421A57 (fig-forth-auto680):05467 FDB EMIT,SPACE
+2A6D 14652A21157713A7 (fig-forth-auto680):05468 FDB I,BLINE,CR,LIT8
+2A75 04 (fig-forth-auto680):05469 FCB 4
+2A76 143C (fig-forth-auto680):05470 FDB XPLOOP
+2A78 FFE5 (fig-forth-auto680):05471 FDB BDUMPL-*-NATWID
+2A7A 1667 (fig-forth-auto680):05472 FDB SEMIS
+ (fig-forth-auto680):05473 *
+ (fig-forth-auto680):05474 * ======>> XX <<
+ (fig-forth-auto680):05475 * ( --- )
+ (fig-forth-auto680):05476 * Mostly for place holding (fig Forth).
+2A7C 84 (fig-forth-auto680):05477 FCB $84
+2A7D 4E4F4F (fig-forth-auto680):05478 FCC 'NOO' ; 'NOOP'
+2A80 D0 (fig-forth-auto680):05479 FCB $D0
+2A81 2A53 (fig-forth-auto680):05480 FDB BDUMP-8
+2A83 1228 (fig-forth-auto680):05481 NOOP FDB NEXT a useful no-op
+2A85 0000000000000000 (fig-forth-auto680):05482 ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
+ 0000000000000000
+ (fig-forth-auto680):05483
+ (fig-forth-auto680):05484 PAGE
+ (fig-forth-auto680):05485 * These things, up through the lable 'REND', are overwritten
+ (fig-forth-auto680):05486 * at time of cold load and should have the same contents
+ (fig-forth-auto680):05487 * as shown here:
+ (fig-forth-auto680):05488 *
+ (fig-forth-auto680):05489 * This can be moved whereever the bottom of the
+ (fig-forth-auto680):05490 * user's dictionary is going to be put.
+ (fig-forth-auto680):05491 *
+2A95 C5 (fig-forth-auto680):05492 FCB $C5 immediate
+2A96 464F5254 (fig-forth-auto680):05493 FCC 'FORT' ; 'FORTH'
+2A9A C8 (fig-forth-auto680):05494 FCB $C8
+2A9B 2A7C (fig-forth-auto680):05495 FDB NOOP-7
+2A9D 1C8621A181A02AC5 (fig-forth-auto680):05496 FORTH FDB DODOES,DOVOC,$81A0,TASK-7
+2AA5 0000 (fig-forth-auto680):05497 FDB 0
+ (fig-forth-auto680):05498 *
+2AA7 28432920466F7274 (fig-forth-auto680):05499 FCC "(C) Forth Interest Group, 1979"
+ 6820496E74657265
+ 73742047726F7570
+ 2C2031393739
+ (fig-forth-auto680):05500
+2AC5 84 (fig-forth-auto680):05501 FCB $84
+2AC6 544153 (fig-forth-auto680):05502 FCC 'TAS' ; 'TASK'
+2AC9 CB (fig-forth-auto680):05503 FCB $CB
+2ACA 2A95 (fig-forth-auto680):05504 FDB FORTH-8
+2ACC 17B91667 (fig-forth-auto680):05505 TASK FDB DOCOL,SEMIS
+ (fig-forth-auto680):05506 *
+ 2AD0 (fig-forth-auto680):05507 REND EQU * ( first empty location in dictionary )
+ (fig-forth-auto680):05508
+ (fig-forth-auto680):05509
+ (fig-forth-auto680):05510
+ (fig-forth-auto680):05511
+ (fig-forth-auto680):05512
+ (fig-forth-auto680):05513
+ (fig-forth-auto680):05514
+ (fig-forth-auto680):05515 PAGE
+ (fig-forth-auto680):05516 OPT L
+ (fig-forth-auto680):05517 END
OSDN Git Service
