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